add ligo-parser
This commit is contained in:
Galfour
parent
84dbf1f7ee
commit
7cc6a681b1
1
src/ligo/parser/.Lexer.ml.tag
Normal file
1
src/ligo/parser/.Lexer.ml.tag
Normal file
@ -0,0 +1 @@
|
||||
ocamlc: -w -42
|
||||
0
src/ligo/parser/.LexerMain.tag
Normal file
0
src/ligo/parser/.LexerMain.tag
Normal file
1
src/ligo/parser/.Parser.mly.tag
Normal file
1
src/ligo/parser/.Parser.mly.tag
Normal file
@ -0,0 +1 @@
|
||||
--explain --external-tokens LexToken --base Parser ParToken.mly
|
||||
0
src/ligo/parser/.ParserMain.tag
Normal file
0
src/ligo/parser/.ParserMain.tag
Normal file
2
src/ligo/parser/.links
Normal file
2
src/ligo/parser/.links
Normal file
@ -0,0 +1,2 @@
|
||||
$HOME/git/OCaml-build/Makefile
|
||||
$HOME/git/OCaml-build/Makefile.cfg
|
||||
1059
src/ligo/parser/AST.ml
Normal file
1059
src/ligo/parser/AST.ml
Normal file
File diff suppressed because it is too large
Load Diff
438
src/ligo/parser/AST.mli
Normal file
438
src/ligo/parser/AST.mli
Normal file
@ -0,0 +1,438 @@
|
||||
(* Abstract Syntax Tree (AST) for Ligo *)
|
||||
|
||||
[@@@warning "-30"]
|
||||
|
||||
open Utils
|
||||
|
||||
(* Regions
|
||||
|
||||
The AST carries all the regions where tokens have been found by the
|
||||
lexer, plus additional regions corresponding to whole subtrees
|
||||
(like entire expressions, patterns etc.). These regions are needed
|
||||
for error reporting and source-to-source transformations. To make
|
||||
these pervasive regions more legible, we define singleton types for
|
||||
the symbols, keywords etc. with suggestive names like "kwd_and"
|
||||
denoting the _region_ of the occurrence of the keyword "and".
|
||||
*)
|
||||
|
||||
type 'a reg = 'a Region.reg
|
||||
|
||||
val nseq_to_region : ('a -> Region.t) -> 'a nseq -> Region.t
|
||||
val nsepseq_to_region : ('a -> Region.t) -> ('a,'sep) nsepseq -> Region.t
|
||||
val sepseq_to_region : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t
|
||||
|
||||
(* Keywords of Ligo *)
|
||||
|
||||
type kwd_begin = Region.t
|
||||
type kwd_const = Region.t
|
||||
type kwd_down = Region.t
|
||||
type kwd_else = Region.t
|
||||
type kwd_end = Region.t
|
||||
type kwd_entrypoint = Region.t
|
||||
type kwd_fail = Region.t
|
||||
type kwd_for = Region.t
|
||||
type kwd_function = Region.t
|
||||
type kwd_if = Region.t
|
||||
type kwd_in = Region.t
|
||||
type kwd_is = Region.t
|
||||
type kwd_match = Region.t
|
||||
type kwd_mod = Region.t
|
||||
type kwd_not = Region.t
|
||||
type kwd_null = Region.t
|
||||
type kwd_of = Region.t
|
||||
type kwd_operations = Region.t
|
||||
type kwd_procedure = Region.t
|
||||
type kwd_record = Region.t
|
||||
type kwd_step = Region.t
|
||||
type kwd_storage = Region.t
|
||||
type kwd_then = Region.t
|
||||
type kwd_to = Region.t
|
||||
type kwd_type = Region.t
|
||||
type kwd_var = Region.t
|
||||
type kwd_while = Region.t
|
||||
type kwd_with = Region.t
|
||||
|
||||
(* Data constructors *)
|
||||
|
||||
type c_False = Region.t
|
||||
type c_None = Region.t
|
||||
type c_Some = Region.t
|
||||
type c_True = Region.t
|
||||
type c_Unit = Region.t
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
type semi = Region.t
|
||||
type comma = Region.t
|
||||
type lpar = Region.t
|
||||
type rpar = Region.t
|
||||
type lbrace = Region.t
|
||||
type rbrace = Region.t
|
||||
type lbracket = Region.t
|
||||
type rbracket = Region.t
|
||||
type cons = Region.t
|
||||
type vbar = Region.t
|
||||
type arrow = Region.t
|
||||
type ass = Region.t
|
||||
type equal = Region.t
|
||||
type colon = Region.t
|
||||
type bool_or = Region.t
|
||||
type bool_and = Region.t
|
||||
type lt = Region.t
|
||||
type leq = Region.t
|
||||
type gt = Region.t
|
||||
type geq = Region.t
|
||||
type neq = Region.t
|
||||
type plus = Region.t
|
||||
type minus = Region.t
|
||||
type slash = Region.t
|
||||
type times = Region.t
|
||||
type dot = Region.t
|
||||
type wild = Region.t
|
||||
type cat = Region.t
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
type eof = Region.t
|
||||
|
||||
(* Literals *)
|
||||
|
||||
type variable = string reg
|
||||
type fun_name = string reg
|
||||
type type_name = string reg
|
||||
type field_name = string reg
|
||||
type map_name = string reg
|
||||
type constr = string reg
|
||||
|
||||
(* Comma-separated non-empty lists *)
|
||||
|
||||
type 'a csv = ('a, comma) nsepseq
|
||||
|
||||
(* Bar-separated non-empty lists *)
|
||||
|
||||
type 'a bsv = ('a, vbar) nsepseq
|
||||
|
||||
(* Parentheses *)
|
||||
|
||||
type 'a par = (lpar * 'a * rpar) reg
|
||||
|
||||
(* Brackets compounds *)
|
||||
|
||||
type 'a brackets = (lbracket * 'a * rbracket) reg
|
||||
|
||||
(* Braced compounds *)
|
||||
|
||||
type 'a braces = (lbrace * 'a * rbrace) reg
|
||||
|
||||
(* The Abstract Syntax Tree *)
|
||||
|
||||
type t = {
|
||||
decl : declaration nseq;
|
||||
eof : eof
|
||||
}
|
||||
|
||||
and ast = t
|
||||
|
||||
and declaration =
|
||||
TypeDecl of type_decl reg
|
||||
| ConstDecl of const_decl reg
|
||||
| StorageDecl of storage_decl reg
|
||||
| OpDecl of operations_decl reg
|
||||
| LambdaDecl of lambda_decl
|
||||
|
||||
and const_decl = {
|
||||
kwd_const : kwd_const;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
const_type : type_expr;
|
||||
equal : equal;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and storage_decl = {
|
||||
kwd_storage : kwd_storage;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
store_type : type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and operations_decl = {
|
||||
kwd_operations : kwd_operations;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
op_type : type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
(* Type declarations *)
|
||||
|
||||
and type_decl = {
|
||||
kwd_type : kwd_type;
|
||||
name : type_name;
|
||||
kwd_is : kwd_is;
|
||||
type_expr : type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and type_expr =
|
||||
Prod of cartesian
|
||||
| Sum of (variant, vbar) nsepseq reg
|
||||
| Record of record_type
|
||||
| TypeApp of (type_name * type_tuple) reg
|
||||
| ParType of type_expr par
|
||||
| TAlias of variable
|
||||
|
||||
and cartesian = (type_expr, times) nsepseq reg
|
||||
|
||||
and variant = (constr * kwd_of * cartesian) reg
|
||||
|
||||
and record_type = (kwd_record * field_decls * kwd_end) reg
|
||||
|
||||
and field_decls = (field_decl, semi) nsepseq
|
||||
|
||||
and field_decl = (variable * colon * type_expr) reg
|
||||
|
||||
and type_tuple = (type_name, comma) nsepseq par
|
||||
|
||||
(* Function and procedure declarations *)
|
||||
|
||||
and lambda_decl =
|
||||
FunDecl of fun_decl reg
|
||||
| ProcDecl of proc_decl reg
|
||||
| EntryDecl of entry_decl reg
|
||||
|
||||
and fun_decl = {
|
||||
kwd_function : kwd_function;
|
||||
name : variable;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
kwd_is : kwd_is;
|
||||
local_decls : local_decl list;
|
||||
block : block reg;
|
||||
kwd_with : kwd_with;
|
||||
return : expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and proc_decl = {
|
||||
kwd_procedure : kwd_procedure;
|
||||
name : variable;
|
||||
param : parameters;
|
||||
kwd_is : kwd_is;
|
||||
local_decls : local_decl list;
|
||||
block : block reg;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and entry_decl = {
|
||||
kwd_entrypoint : kwd_entrypoint;
|
||||
name : variable;
|
||||
param : parameters;
|
||||
kwd_is : kwd_is;
|
||||
local_decls : local_decl list;
|
||||
block : block reg;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and parameters = (param_decl, semi) nsepseq par
|
||||
|
||||
and param_decl =
|
||||
ParamConst of param_const
|
||||
| ParamVar of param_var
|
||||
|
||||
and param_const = (kwd_const * variable * colon * type_expr) reg
|
||||
|
||||
and param_var = (kwd_var * variable * colon * type_expr) reg
|
||||
|
||||
and block = {
|
||||
opening : kwd_begin;
|
||||
instr : instructions;
|
||||
terminator : semi option;
|
||||
close : kwd_end
|
||||
}
|
||||
|
||||
and local_decl =
|
||||
LocalLam of lambda_decl
|
||||
| LocalConst of const_decl reg
|
||||
| LocalVar of var_decl reg
|
||||
|
||||
and var_decl = {
|
||||
kwd_var : kwd_var;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
var_type : type_expr;
|
||||
ass : ass;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and instructions = (instruction, semi) nsepseq reg
|
||||
|
||||
and instruction =
|
||||
Single of single_instr
|
||||
| Block of block reg
|
||||
|
||||
and single_instr =
|
||||
Cond of conditional reg
|
||||
| Match of match_instr reg
|
||||
| Ass of ass_instr
|
||||
| Loop of loop
|
||||
| ProcCall of fun_call
|
||||
| Null of kwd_null
|
||||
| Fail of (kwd_fail * expr) reg
|
||||
|
||||
and conditional = {
|
||||
kwd_if : kwd_if;
|
||||
test : expr;
|
||||
kwd_then : kwd_then;
|
||||
ifso : instruction;
|
||||
kwd_else : kwd_else;
|
||||
ifnot : instruction
|
||||
}
|
||||
|
||||
and match_instr = {
|
||||
kwd_match : kwd_match;
|
||||
expr : expr;
|
||||
kwd_with : kwd_with;
|
||||
lead_vbar : vbar option;
|
||||
cases : cases;
|
||||
kwd_end : kwd_end
|
||||
}
|
||||
|
||||
and cases = (case, vbar) nsepseq reg
|
||||
|
||||
and case = (pattern * arrow * instruction) reg
|
||||
|
||||
and ass_instr = (variable * ass * expr) reg
|
||||
|
||||
and loop =
|
||||
While of while_loop
|
||||
| For of for_loop
|
||||
|
||||
and while_loop = (kwd_while * expr * block reg) reg
|
||||
|
||||
and for_loop =
|
||||
ForInt of for_int reg
|
||||
| ForCollect of for_collect reg
|
||||
|
||||
and for_int = {
|
||||
kwd_for : kwd_for;
|
||||
ass : ass_instr;
|
||||
down : kwd_down option;
|
||||
kwd_to : kwd_to;
|
||||
bound : expr;
|
||||
step : (kwd_step * expr) option;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and for_collect = {
|
||||
kwd_for : kwd_for;
|
||||
var : variable;
|
||||
bind_to : (arrow * variable) option;
|
||||
kwd_in : kwd_in;
|
||||
expr : expr;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
(* Expressions *)
|
||||
|
||||
and expr =
|
||||
Or of (expr * bool_or * expr) reg
|
||||
| And of (expr * bool_and * expr) reg
|
||||
| Lt of (expr * lt * expr) reg
|
||||
| Leq of (expr * leq * expr) reg
|
||||
| Gt of (expr * gt * expr) reg
|
||||
| Geq of (expr * geq * expr) reg
|
||||
| Equal of (expr * equal * expr) reg
|
||||
| Neq of (expr * neq * expr) reg
|
||||
| Cat of (expr * cat * expr) reg
|
||||
| Cons of (expr * cons * expr) reg
|
||||
| Add of (expr * plus * expr) reg
|
||||
| Sub of (expr * minus * expr) reg
|
||||
| Mult of (expr * times * expr) reg
|
||||
| Div of (expr * slash * expr) reg
|
||||
| Mod of (expr * kwd_mod * expr) reg
|
||||
| Neg of (minus * expr) reg
|
||||
| Not of (kwd_not * expr) reg
|
||||
| Int of (Lexer.lexeme * Z.t) reg
|
||||
| Var of Lexer.lexeme reg
|
||||
| String of Lexer.lexeme reg
|
||||
| Bytes of (Lexer.lexeme * MBytes.t) reg
|
||||
| False of c_False
|
||||
| True of c_True
|
||||
| Unit of c_Unit
|
||||
| Tuple of tuple
|
||||
| List of (expr, comma) nsepseq brackets
|
||||
| EmptyList of empty_list
|
||||
| Set of (expr, comma) nsepseq braces
|
||||
| EmptySet of empty_set
|
||||
| NoneExpr of none_expr
|
||||
| FunCall of fun_call
|
||||
| ConstrApp of constr_app
|
||||
| SomeApp of (c_Some * arguments) reg
|
||||
| MapLookUp of map_lookup reg
|
||||
| ParExpr of expr par
|
||||
|
||||
and tuple = (expr, comma) nsepseq par
|
||||
|
||||
and empty_list =
|
||||
(lbracket * rbracket * colon * type_expr) par
|
||||
|
||||
and empty_set =
|
||||
(lbrace * rbrace * colon * type_expr) par
|
||||
|
||||
and none_expr =
|
||||
(c_None * colon * type_expr) par
|
||||
|
||||
and fun_call = (fun_name * arguments) reg
|
||||
|
||||
and arguments = tuple
|
||||
|
||||
and constr_app = (constr * arguments) reg
|
||||
|
||||
and map_lookup = {
|
||||
map_name : variable;
|
||||
selector : dot;
|
||||
index : expr brackets
|
||||
}
|
||||
|
||||
(* Patterns *)
|
||||
|
||||
and pattern = (core_pattern, cons) nsepseq reg
|
||||
|
||||
and core_pattern =
|
||||
PVar of Lexer.lexeme reg
|
||||
| PWild of wild
|
||||
| PInt of (Lexer.lexeme * Z.t) reg
|
||||
| PBytes of (Lexer.lexeme * MBytes.t) reg
|
||||
| PString of Lexer.lexeme reg
|
||||
| PUnit of c_Unit
|
||||
| PFalse of c_False
|
||||
| PTrue of c_True
|
||||
| PNone of c_None
|
||||
| PSome of (c_Some * core_pattern par) reg
|
||||
| PList of list_pattern
|
||||
| PTuple of (core_pattern, comma) nsepseq par
|
||||
|
||||
and list_pattern =
|
||||
Sugar of (core_pattern, comma) sepseq brackets
|
||||
| Raw of (core_pattern * cons * pattern) par
|
||||
|
||||
(* Projecting regions *)
|
||||
|
||||
val type_expr_to_region : type_expr -> Region.t
|
||||
|
||||
val expr_to_region : expr -> Region.t
|
||||
|
||||
val instr_to_region : instruction -> Region.t
|
||||
|
||||
val core_pattern_to_region : core_pattern -> Region.t
|
||||
|
||||
val local_decl_to_region : local_decl -> Region.t
|
||||
|
||||
(* Printing *)
|
||||
|
||||
val print_tokens : t -> unit
|
||||
669
src/ligo/parser/AST2.ml
Normal file
669
src/ligo/parser/AST2.ml
Normal file
@ -0,0 +1,669 @@
|
||||
[@@@warning "-30"]
|
||||
|
||||
module I = AST
|
||||
|
||||
open Region
|
||||
|
||||
module SMap = Map.Make(String)
|
||||
|
||||
module O = struct
|
||||
type type_name = string
|
||||
type var_name = string
|
||||
|
||||
type pattern =
|
||||
PVar of var_name
|
||||
| PWild
|
||||
| PInt of Z.t
|
||||
| PBytes of MBytes.t
|
||||
| PString of string
|
||||
| PUnit
|
||||
| PFalse
|
||||
| PTrue
|
||||
| PNone
|
||||
| PSome of pattern
|
||||
| PCons of pattern * pattern
|
||||
| PNull
|
||||
| PTuple of pattern list
|
||||
|
||||
type type_expr =
|
||||
Prod of type_expr list
|
||||
| Sum of (type_name * type_expr) list
|
||||
| Record of (type_name * type_expr) list
|
||||
| TypeApp of type_name * (type_expr list)
|
||||
| Function of { args: type_expr list; ret: type_expr }
|
||||
| Ref of type_expr
|
||||
| Unit
|
||||
| Int
|
||||
|
||||
type typed_var = { name:var_name; ty:type_expr }
|
||||
|
||||
type type_decl = { name:string; ty:type_expr }
|
||||
|
||||
type expr =
|
||||
App of { operator: operator; arguments: expr list }
|
||||
| Var of var_name
|
||||
| Constant of constant
|
||||
| Lambda of lambda
|
||||
|
||||
and decl = { name:var_name; ty:type_expr; value: expr }
|
||||
|
||||
and lambda = {
|
||||
parameters: type_expr SMap.t;
|
||||
declarations: decl list;
|
||||
instructions: instr list;
|
||||
result: expr;
|
||||
}
|
||||
|
||||
and operator =
|
||||
Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
|
||||
| Neg | Not
|
||||
| Tuple | Set | List
|
||||
| MapLookup
|
||||
| Function of string
|
||||
|
||||
and constant =
|
||||
Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True
|
||||
| Null of type_expr | EmptySet of type_expr | CNone of type_expr
|
||||
|
||||
and instr =
|
||||
Assignment of { name: var_name; value: expr }
|
||||
| While of { condition: expr; body: instr list }
|
||||
| ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list }
|
||||
| If of { condition: expr; ifso: instr list; ifnot: instr list }
|
||||
| Match of { expr: expr; cases: (pattern * instr list) list }
|
||||
| DropUnit of expr (* expr returns unit, drop the result. *)
|
||||
| Fail of { expr: expr }
|
||||
|
||||
type ast = {
|
||||
types : type_decl list;
|
||||
storage_decl : typed_var;
|
||||
operations_decl : typed_var;
|
||||
declarations : decl list;
|
||||
}
|
||||
end
|
||||
|
||||
(* open Sanity: *)
|
||||
let (|>) v f = f v (* pipe f to v *)
|
||||
let (@@) f v = f v (* apply f on v *)
|
||||
let (@.) f g x = f (g x) (* compose *)
|
||||
let map f l = List.rev (List.rev_map f l)
|
||||
(* TODO: check that List.to_seq, List.append and SMap.of_seq are not broken
|
||||
(i.e. check that they are tail-recursive) *)
|
||||
let append_map f l = map f l |> List.flatten
|
||||
let append l1 l2 = List.append l1 l2
|
||||
let list_to_map l = List.fold_left (fun m (k,v) -> SMap.add k v m) SMap.empty l
|
||||
let fold_map f a l =
|
||||
let f (acc, l) elem =
|
||||
let acc', elem' = f acc elem
|
||||
in acc', (elem' :: l) in
|
||||
let last_acc, last_l = List.fold_left f (a, []) l
|
||||
in last_acc, List.rev last_l
|
||||
|
||||
(* Simplify the AST *)
|
||||
|
||||
let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list =
|
||||
fun (first, rest) -> first :: (map snd rest)
|
||||
|
||||
let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list =
|
||||
function
|
||||
None -> []
|
||||
| Some nsepseq -> s_nsepseq nsepseq
|
||||
|
||||
let s_name {value=name; region} : O.var_name =
|
||||
let () = ignore (region) in
|
||||
name
|
||||
|
||||
let rec s_cartesian {value=sequence; region} : O.type_expr =
|
||||
let () = ignore (region) in
|
||||
Prod (map s_type_expr (s_nsepseq sequence))
|
||||
|
||||
and s_sum_type {value=sequence; region} : O.type_expr =
|
||||
let () = ignore (region) in
|
||||
Sum (map s_variant (s_nsepseq sequence))
|
||||
|
||||
and s_variant {value=(constr, kwd_of, cartesian); region} =
|
||||
let () = ignore (kwd_of,region) in
|
||||
(s_name constr, s_cartesian cartesian)
|
||||
|
||||
and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr =
|
||||
let () = ignore (kwd_record,region,kwd_end) in
|
||||
Record (map s_field_decl (s_nsepseq field_decls))
|
||||
|
||||
and s_field_decl {value=(var, colon, type_expr); region} =
|
||||
let () = ignore (colon,region) in
|
||||
(s_name var, s_type_expr type_expr)
|
||||
|
||||
and s_type_app {value=(type_name,type_tuple); region} : O.type_expr =
|
||||
let () = ignore (region) in
|
||||
TypeApp (s_name type_name, s_type_tuple type_tuple)
|
||||
|
||||
and s_type_tuple ({value=(lpar, sequence, rpar); region} : (I.type_name, I.comma) Utils.nsepseq I.par) : O.type_expr list =
|
||||
let () = ignore (lpar,rpar,region) in
|
||||
(* TODO: the grammar should allow any type expr, not just type_name in the tuple elements *)
|
||||
map s_type_expr (map (fun a -> I.TAlias a) (s_nsepseq sequence))
|
||||
|
||||
and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr =
|
||||
let () = ignore (lpar,rpar,region) in
|
||||
s_type_expr type_expr
|
||||
|
||||
and s_type_alias name : O.type_expr =
|
||||
let () = ignore () in
|
||||
TypeApp (s_name name, [])
|
||||
|
||||
and s_type_expr : I.type_expr -> O.type_expr = function
|
||||
Prod cartesian -> s_cartesian cartesian
|
||||
| Sum sum_type -> s_sum_type sum_type
|
||||
| Record record_type -> s_record_type record_type
|
||||
| TypeApp type_app -> s_type_app type_app
|
||||
| ParType par_type -> s_par_type par_type
|
||||
| TAlias type_alias -> s_type_alias type_alias
|
||||
|
||||
|
||||
let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl =
|
||||
let () = ignore (kwd_type,kwd_is,terminator,region) in
|
||||
O.{ name = s_name name; ty = s_type_expr type_expr }
|
||||
|
||||
let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var =
|
||||
let () = ignore (kwd_storage,colon,terminator,region) in
|
||||
O.{ name = s_name name; ty = s_type_expr store_type }
|
||||
|
||||
let s_operations_decl I.{value={kwd_operations;name;colon;op_type;terminator}; region} : O.typed_var =
|
||||
let () = ignore (kwd_operations,colon,terminator,region) in
|
||||
O.{ name = s_name name; ty = s_type_expr op_type }
|
||||
|
||||
let s_empty_list {value=(l, (lbracket, rbracket, colon, type_expr), r); region} : O.expr =
|
||||
let () = ignore (l, lbracket, rbracket, colon, r, region) in
|
||||
Constant (Null (s_type_expr type_expr))
|
||||
|
||||
let s_empty_set {value=(l, (lbrace, rbrace, colon, type_expr), r); region} : O.expr =
|
||||
let () = ignore (l, lbrace, rbrace, colon, r, region) in
|
||||
Constant (EmptySet (s_type_expr type_expr))
|
||||
|
||||
let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr =
|
||||
let () = ignore (l, c_None, colon, r, region) in
|
||||
Constant (CNone (s_type_expr type_expr))
|
||||
|
||||
let rec bin l operator r = O.App { operator; arguments = [s_expr l; s_expr r] }
|
||||
and una operator v = O.App { operator; arguments = [s_expr v] }
|
||||
and s_expr : I.expr -> O.expr =
|
||||
function
|
||||
Or {value=(l, bool_or, r); region} -> let () = ignore (region, bool_or) in bin l Or r
|
||||
| And {value=(l, bool_and, r); region} -> let () = ignore (region,bool_and) in bin l And r
|
||||
| Lt {value=(l, lt, r); region} -> let () = ignore (region, lt) in bin l Lt r
|
||||
| Leq {value=(l, leq, r); region} -> let () = ignore (region, leq) in bin l Leq r
|
||||
| Gt {value=(l, gt, r); region} -> let () = ignore (region, gt) in bin l Gt r
|
||||
| Geq {value=(l, geq, r); region} -> let () = ignore (region, geq) in bin l Geq r
|
||||
| Equal {value=(l, equal, r); region} -> let () = ignore (region, equal) in bin l Equal r
|
||||
| Neq {value=(l, neq, r); region} -> let () = ignore (region, neq) in bin l Neq r
|
||||
| Cat {value=(l, cat, r); region} -> let () = ignore (region, cat) in bin l Cat r
|
||||
| Cons {value=(l, cons, r); region} -> let () = ignore (region, cons) in bin l Cons r
|
||||
| Add {value=(l, plus, r); region} -> let () = ignore (region, plus) in bin l Add r
|
||||
| Sub {value=(l, minus, r); region} -> let () = ignore (region, minus) in bin l Sub r
|
||||
| Mult {value=(l, times, r); region} -> let () = ignore (region, times) in bin l Mult r
|
||||
| Div {value=(l, slash, r); region} -> let () = ignore (region, slash) in bin l Div r
|
||||
| Mod {value=(l, kwd_mod, r); region} -> let () = ignore (region, kwd_mod) in bin l Mod r
|
||||
| Neg {value=(minus, expr); region} -> let () = ignore (region, minus) in una Neg expr
|
||||
| Not {value=(kwd_not, expr); region} -> let () = ignore (region, kwd_not) in una Not expr
|
||||
| Int {value=(lexeme, z); region} -> let () = ignore (region, lexeme) in Constant (Int z)
|
||||
| Var {value=lexeme; region} -> let () = ignore (region) in Var lexeme
|
||||
| String {value=s; region} -> let () = ignore (region) in Constant (String s)
|
||||
| Bytes {value=(lexeme, mbytes); region} -> let () = ignore (region, lexeme) in Constant (Bytes mbytes)
|
||||
| False c_False -> let () = ignore (c_False) in Constant (False)
|
||||
| True c_True -> let () = ignore (c_True) in Constant (True)
|
||||
| Unit c_Unit -> let () = ignore (c_Unit) in Constant (Unit)
|
||||
| Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in App { operator = Tuple; arguments = map s_expr (s_nsepseq tuple)}
|
||||
| List list -> s_list list
|
||||
| EmptyList empty_list -> s_empty_list empty_list
|
||||
| Set set -> s_set set
|
||||
| EmptySet empty_set -> s_empty_set empty_set
|
||||
| NoneExpr none_expr -> s_none none_expr
|
||||
| FunCall fun_call -> s_fun_call fun_call
|
||||
| ConstrApp constr_app -> s_constr_app constr_app
|
||||
| SomeApp some_app -> s_some_app some_app
|
||||
| MapLookUp map_lookup -> s_map_lookup map_lookup
|
||||
| ParExpr {value=(lpar,expr,rpar); region} -> let () = ignore (lpar,rpar,region) in s_expr expr
|
||||
|
||||
and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr =
|
||||
let {value = lbracket, index_expr, rbracket; region=region2} = index in
|
||||
let () = ignore (selector, lbracket, rbracket, region2, region) in
|
||||
App { operator = MapLookup; arguments = [Var (s_name map_name); s_expr index_expr] }
|
||||
|
||||
and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region} : O.expr =
|
||||
let () = ignore (c_Some,l,r,region2,region) in
|
||||
match s_nsepseq arguments with
|
||||
[] -> failwith "tuple cannot be empty"
|
||||
| [a] -> s_expr a
|
||||
| l -> App { operator = Tuple; arguments = map s_expr l }
|
||||
|
||||
and s_list {value=(l, list, r); region} : O.expr =
|
||||
let () = ignore (l, r, region) in
|
||||
App { operator = List; arguments = map s_expr (s_nsepseq list) }
|
||||
|
||||
and s_set {value=(l, set, r); region} : O.expr =
|
||||
let () = ignore (l, r, region) in
|
||||
App { operator = Set; arguments = map s_expr (s_nsepseq set) }
|
||||
|
||||
and s_pattern {value=sequence; region} : O.pattern =
|
||||
let () = ignore (region) in
|
||||
s_pattern_conses (s_nsepseq sequence)
|
||||
|
||||
and s_pattern_conses : I.core_pattern list -> O.pattern = function
|
||||
[] -> assert false
|
||||
| [p] -> s_core_pattern p
|
||||
| hd :: tl -> PCons (s_core_pattern hd, s_pattern_conses tl)
|
||||
|
||||
and s_case ({value=(pattern, arrow, instruction); region} : I.case) : O.pattern * O.instr list =
|
||||
let () = ignore (arrow,region) in
|
||||
s_pattern pattern, s_instruction instruction
|
||||
|
||||
and s_core_pattern : I.core_pattern -> O.pattern = function
|
||||
PVar var -> PVar (s_name var)
|
||||
| PWild wild -> let () = ignore (wild) in PWild
|
||||
| PInt {value=(si,i);region} -> let () = ignore (si,region) in PInt i
|
||||
| PBytes {value=(sb,b);region} -> let () = ignore (sb,region) in PBytes b
|
||||
| PString {value=s;region} -> let () = ignore (region) in PString s
|
||||
| PUnit region -> let () = ignore (region) in PUnit
|
||||
| PFalse region -> let () = ignore (region) in PFalse
|
||||
| PTrue region -> let () = ignore (region) in PTrue
|
||||
| PNone region -> let () = ignore (region) in PNone
|
||||
| PSome psome -> s_psome psome
|
||||
| PList pattern -> s_list_pattern pattern
|
||||
| PTuple ptuple -> s_ptuple ptuple
|
||||
|
||||
and s_list_pattern = function
|
||||
Sugar sugar -> s_sugar sugar
|
||||
| Raw raw -> s_raw raw
|
||||
|
||||
and s_sugar {value=(lbracket, sequence, rbracket); region} : O.pattern =
|
||||
let () = ignore (lbracket, rbracket, region) in
|
||||
List.fold_left (fun acc p -> O.PCons (s_core_pattern p, acc))
|
||||
O.PNull
|
||||
(s_sepseq sequence);
|
||||
|
||||
and s_raw {value=(lpar, (core_pattern, cons, pattern), rpar); region} =
|
||||
let () = ignore (lpar, cons, rpar, region) in
|
||||
O.PCons (s_core_pattern core_pattern, s_pattern pattern)
|
||||
|
||||
and s_ptuple {value=(lpar, sequence, rpar); region} =
|
||||
let () = ignore (lpar, rpar, region) in
|
||||
PTuple (map s_core_pattern (s_nsepseq sequence))
|
||||
|
||||
and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern =
|
||||
let () = ignore (c_Some,l,r,region2,region) in
|
||||
PSome (s_core_pattern psome)
|
||||
|
||||
and s_const_decl I.{value={kwd_const;name;colon;const_type;equal;init;terminator}; region} : O.decl =
|
||||
let () = ignore (kwd_const,colon,equal,terminator,region) in
|
||||
O.{ name = s_name name; ty = s_type_expr const_type; value = s_expr init }
|
||||
|
||||
and s_param_const {value=(kwd_const,variable,colon,type_expr); region} : string * O.type_expr =
|
||||
let () = ignore (kwd_const,colon,region) in
|
||||
s_name variable, s_type_expr type_expr
|
||||
|
||||
and s_param_var {value=(kwd_var,variable,colon,type_expr); region} : string * O.type_expr =
|
||||
let () = ignore (kwd_var,colon,region) in
|
||||
s_name variable, s_type_expr type_expr
|
||||
|
||||
and s_param_decl : I.param_decl -> string * O.type_expr = function
|
||||
ParamConst p -> s_param_const p
|
||||
| ParamVar p -> s_param_var p
|
||||
|
||||
and s_parameters ({value=(lpar,param_decl,rpar);region} : I.parameters) : (string * O.type_expr) list =
|
||||
let () = ignore (lpar,rpar,region) in
|
||||
let l = (s_nsepseq param_decl) in
|
||||
map s_param_decl l
|
||||
|
||||
and s_var_decl I.{value={kwd_var;name;colon;var_type;ass;init;terminator}; region} : O.decl =
|
||||
let () = ignore (kwd_var,colon,ass,terminator,region) in
|
||||
O.{
|
||||
name = s_name name;
|
||||
ty = s_type_expr var_type;
|
||||
value = s_expr init
|
||||
}
|
||||
|
||||
and s_local_decl : I.local_decl -> O.decl = function
|
||||
LocalLam decl -> s_lambda_decl decl
|
||||
| LocalConst decl -> s_const_decl decl
|
||||
| LocalVar decl -> s_var_decl decl
|
||||
|
||||
and s_instructions ({value=sequence; region} : I.instructions) : O.instr list =
|
||||
let () = ignore (region) in
|
||||
append_map s_instruction (s_nsepseq sequence)
|
||||
|
||||
and s_instruction : I.instruction -> O.instr list = function
|
||||
Single instr -> s_single_instr instr
|
||||
| Block block -> (s_block block)
|
||||
|
||||
and s_conditional I.{kwd_if;test;kwd_then;ifso;kwd_else;ifnot} : O.instr =
|
||||
let () = ignore (kwd_if,kwd_then,kwd_else) in
|
||||
If { condition = s_expr test; ifso = s_instruction ifso; ifnot = s_instruction ifnot }
|
||||
|
||||
and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr =
|
||||
let {value=cases;region} = cases in
|
||||
let () = ignore (kwd_match,kwd_with,lead_vbar,kwd_end,region) in
|
||||
Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases) }
|
||||
|
||||
and s_ass_instr {value=(variable,ass,expr); region} : O.instr =
|
||||
let () = ignore (ass,region) in
|
||||
Assignment { name = s_name variable; value = s_expr expr }
|
||||
|
||||
and s_while_loop {value=(kwd_while, expr, block); region} : O.instr list =
|
||||
let () = ignore (kwd_while,region) in
|
||||
[While {condition = s_expr expr; body = s_block block}]
|
||||
|
||||
and s_for_loop : I.for_loop -> O.instr list = function
|
||||
ForInt for_int -> s_for_int for_int
|
||||
| ForCollect for_collect -> s_for_collect for_collect
|
||||
|
||||
and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.for_int reg) : O.instr list =
|
||||
let {value=(variable,ass_kwd,expr);region = ass_region} = ass in
|
||||
let () = ignore (kwd_for,ass_region,ass_kwd,kwd_to,region) in
|
||||
let name = s_name variable in
|
||||
let condition, operator = match down with Some kwd_down -> ignore kwd_down; O.Gt, O.Sub
|
||||
| None -> O.Lt, O.Add in
|
||||
let step = s_step step
|
||||
in [
|
||||
Assignment { name; value = s_expr expr };
|
||||
(* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *)
|
||||
While {
|
||||
condition = App { operator = condition;
|
||||
arguments = [Var name; s_expr bound] };
|
||||
body = append (s_block block)
|
||||
[O.Assignment { name;
|
||||
value = App { operator;
|
||||
arguments = [Var name; step]}}]
|
||||
}
|
||||
]
|
||||
|
||||
and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_collect reg) : O.instr list =
|
||||
let () = ignore (kwd_for,kwd_in) in
|
||||
[
|
||||
O.ForCollection {
|
||||
list = s_expr expr;
|
||||
key = s_name var;
|
||||
value = s_bind_to bind_to;
|
||||
body = s_block block
|
||||
}
|
||||
]
|
||||
|
||||
and s_step : (I.kwd_step * I.expr) option -> O.expr = function
|
||||
Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr
|
||||
| None -> Constant (Int (Z.of_int 1))
|
||||
|
||||
and s_bind_to : (I.arrow * I.variable) option -> O.var_name option = function
|
||||
Some (arrow, variable) -> let () = ignore (arrow) in Some (s_name variable)
|
||||
| None -> None
|
||||
|
||||
and s_loop : I.loop -> O.instr list = function
|
||||
While while_loop -> s_while_loop while_loop
|
||||
| For for_loop -> s_for_loop for_loop
|
||||
|
||||
and s_fun_call {value=(fun_name, arguments); region} : O.expr =
|
||||
let () = ignore (region) in
|
||||
App { operator = Function (s_name fun_name); arguments = s_arguments arguments }
|
||||
|
||||
and s_constr_app {value=(constr, arguments); region} : O.expr =
|
||||
let () = ignore (region) in
|
||||
App { operator = Function (s_name constr); arguments = s_arguments arguments }
|
||||
|
||||
and s_arguments {value=(lpar, sequence, rpar); region} =
|
||||
let () = ignore (lpar,rpar,region) in
|
||||
map s_expr (s_nsepseq sequence);
|
||||
|
||||
and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr =
|
||||
let () = ignore (kwd_fail) in
|
||||
Fail { expr = s_expr expr }
|
||||
|
||||
|
||||
|
||||
|
||||
and s_single_instr : I.single_instr -> O.instr list = function
|
||||
Cond {value; _} -> [s_conditional value]
|
||||
| Match {value; _} -> [s_match_instr value]
|
||||
| Ass instr -> [s_ass_instr instr]
|
||||
| Loop loop -> s_loop loop
|
||||
| ProcCall fun_call -> [DropUnit (s_fun_call fun_call)]
|
||||
| Null kwd_null -> let () = ignore (kwd_null) in
|
||||
[]
|
||||
| Fail {value; _} -> [s_fail value]
|
||||
|
||||
and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list =
|
||||
let () = ignore (opening,terminator,close) in
|
||||
s_instructions instr
|
||||
|
||||
and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl =
|
||||
let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in
|
||||
O.{
|
||||
name = s_name name;
|
||||
ty = Function { args = map snd (s_parameters param); ret = s_type_expr ret_type };
|
||||
value = Lambda {
|
||||
parameters = s_parameters param |> list_to_map;
|
||||
declarations = map s_local_decl local_decls;
|
||||
instructions = s_block block;
|
||||
result = s_expr return
|
||||
}
|
||||
}
|
||||
|
||||
and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} =
|
||||
let () = ignore (kwd_procedure,kwd_is,terminator,region) in
|
||||
O.{
|
||||
name = s_name name;
|
||||
ty = Function { args = map snd (s_parameters param); ret = Unit };
|
||||
value = Lambda {
|
||||
parameters = s_parameters param |> list_to_map;
|
||||
declarations = map s_local_decl local_decls;
|
||||
instructions = s_block block;
|
||||
result = O.Constant O.Unit
|
||||
}
|
||||
}
|
||||
|
||||
and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;terminator}; region} =
|
||||
let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in
|
||||
O.{
|
||||
name = s_name name;
|
||||
ty = Function { args = map snd (s_parameters param); ret = Unit };
|
||||
value = Lambda {
|
||||
parameters = s_parameters param |> list_to_map;
|
||||
declarations = map s_local_decl local_decls;
|
||||
instructions = s_block block;
|
||||
result = O.Constant O.Unit
|
||||
}
|
||||
}
|
||||
|
||||
and s_lambda_decl : I.lambda_decl -> O.decl = function
|
||||
FunDecl fun_decl -> s_fun_decl fun_decl
|
||||
| EntryDecl entry_decl -> s_entry_decl entry_decl
|
||||
| ProcDecl proc_decl -> s_proc_decl proc_decl
|
||||
|
||||
type tmp_ast = {
|
||||
types : O.type_decl list;
|
||||
storage_decl : O.typed_var option;
|
||||
operations_decl : O.typed_var option;
|
||||
declarations : O.decl list;
|
||||
}
|
||||
|
||||
|
||||
let s_declaration (ast : tmp_ast) : I.declaration -> tmp_ast = function
|
||||
TypeDecl t -> { ast with types = (s_type_decl t) :: ast.types }
|
||||
| ConstDecl c -> { ast with declarations = (s_const_decl c) :: ast.declarations }
|
||||
| StorageDecl s -> { ast with storage_decl = Some (s_storage_decl s) }
|
||||
| OpDecl o -> { ast with operations_decl = Some (s_operations_decl o) }
|
||||
| LambdaDecl l -> { ast with declarations = (s_lambda_decl l) :: ast.declarations }
|
||||
|
||||
let s_ast (ast : I.ast) : O.ast =
|
||||
let I.{decl=(decl1,decls);eof} = ast in
|
||||
let () = ignore (eof) in
|
||||
let {types; storage_decl; operations_decl; declarations} =
|
||||
List.fold_left s_declaration
|
||||
{ types = [];
|
||||
storage_decl = None;
|
||||
operations_decl = None;
|
||||
declarations = [] }
|
||||
( decl1 :: decls ) in
|
||||
let storage_decl = match storage_decl with
|
||||
Some x -> x
|
||||
| None -> failwith "Missing storage declaration" in
|
||||
let operations_decl = match operations_decl with
|
||||
Some x -> x
|
||||
| None -> failwith "Missing storage declaration"
|
||||
in {types; storage_decl; operations_decl; declarations}
|
||||
|
||||
|
||||
|
||||
|
||||
(* let s_token region lexeme = *)
|
||||
(* printf "%s: %s\n"(compact region) lexeme *)
|
||||
|
||||
(* and s_var {region; value=lexeme} = *)
|
||||
(* printf "%s: Ident \"%s\"\n" (compact region) lexeme *)
|
||||
|
||||
(* and s_constr {region; value=lexeme} = *)
|
||||
(* printf "%s: Constr \"%s\"\n" *)
|
||||
(* (compact region) lexeme *)
|
||||
|
||||
(* and s_string {region; value=lexeme} = *)
|
||||
(* printf "%s: String \"%s\"\n" *)
|
||||
(* (compact region) lexeme *)
|
||||
|
||||
(* and s_bytes {region; value = lexeme, abstract} = *)
|
||||
(* printf "%s: Bytes (\"%s\", \"0x%s\")\n" *)
|
||||
(* (compact region) lexeme *)
|
||||
(* (MBytes.to_hex abstract |> Hex.to_string) *)
|
||||
|
||||
(* and s_int {region; value = lexeme, abstract} = *)
|
||||
(* printf "%s: Int (\"%s\", %s)\n" *)
|
||||
(* (compact region) lexeme *)
|
||||
(* (Z.to_string abstract) *)
|
||||
|
||||
|
||||
(* and s_parameters {value=node; _} = *)
|
||||
(* let lpar, sequence, rpar = node in *)
|
||||
(* s_token lpar "("; *)
|
||||
(* s_nsepseq ";" s_param_decl sequence; *)
|
||||
(* s_token rpar ")" *)
|
||||
|
||||
(* and s_param_decl = function *)
|
||||
(* ParamConst param_const -> s_param_const param_const *)
|
||||
(* | ParamVar param_var -> s_param_var param_var *)
|
||||
|
||||
(* and s_region_cases {value=sequence; _} = *)
|
||||
(* s_nsepseq "|" s_case sequence *)
|
||||
|
||||
(* and s_expr = function *)
|
||||
(* Or {value = expr1, bool_or, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token bool_or "||"; s_expr expr2 *)
|
||||
(* | And {value = expr1, bool_and, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token bool_and "&&"; s_expr expr2 *)
|
||||
(* | Lt {value = expr1, lt, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token lt "<"; s_expr expr2 *)
|
||||
(* | Leq {value = expr1, leq, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token leq "<="; s_expr expr2 *)
|
||||
(* | Gt {value = expr1, gt, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token gt ">"; s_expr expr2 *)
|
||||
(* | Geq {value = expr1, geq, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token geq ">="; s_expr expr2 *)
|
||||
(* | Equal {value = expr1, equal, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token equal "="; s_expr expr2 *)
|
||||
(* | Neq {value = expr1, neq, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token neq "=/="; s_expr expr2 *)
|
||||
(* | Cat {value = expr1, cat, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token cat "^"; s_expr expr2 *)
|
||||
(* | Cons {value = expr1, cons, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token cons "<:"; s_expr expr2 *)
|
||||
(* | Add {value = expr1, add, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token add "+"; s_expr expr2 *)
|
||||
(* | Sub {value = expr1, sub, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token sub "-"; s_expr expr2 *)
|
||||
(* | Mult {value = expr1, mult, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token mult "*"; s_expr expr2 *)
|
||||
(* | Div {value = expr1, div, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token div "/"; s_expr expr2 *)
|
||||
(* | Mod {value = expr1, kwd_mod, expr2; _} -> *)
|
||||
(* s_expr expr1; s_token kwd_mod "mod"; s_expr expr2 *)
|
||||
(* | Neg {value = minus, expr; _} -> *)
|
||||
(* s_token minus "-"; s_expr expr *)
|
||||
(* | Not {value = kwd_not, expr; _} -> *)
|
||||
(* s_token kwd_not "not"; s_expr expr *)
|
||||
(* | Int i -> s_int i *)
|
||||
(* | Var var -> s_var var *)
|
||||
(* | String s -> s_string s *)
|
||||
(* | Bytes b -> s_bytes b *)
|
||||
(* | False region -> s_token region "False" *)
|
||||
(* | True region -> s_token region "True" *)
|
||||
(* | Unit region -> s_token region "Unit" *)
|
||||
(* | Tuple tuple -> s_tuple tuple *)
|
||||
(* | List list -> s_list list *)
|
||||
(* | EmptyList elist -> s_empty_list elist *)
|
||||
(* | Set set -> s_set set *)
|
||||
(* | EmptySet eset -> s_empty_set eset *)
|
||||
(* | NoneExpr nexpr -> s_none_expr nexpr *)
|
||||
(* | FunCall fun_call -> s_fun_call fun_call *)
|
||||
(* | ConstrApp capp -> s_constr_app capp *)
|
||||
(* | SomeApp sapp -> s_some_app sapp *)
|
||||
(* | MapLookUp lookup -> s_map_lookup lookup *)
|
||||
(* | ParExpr pexpr -> s_par_expr pexpr *)
|
||||
|
||||
(* and s_list {value=node; _} = *)
|
||||
(* let lbra, sequence, rbra = node in *)
|
||||
(* s_token lbra "["; *)
|
||||
(* s_nsepseq "," s_expr sequence; *)
|
||||
(* s_token rbra "]" *)
|
||||
|
||||
(* and s_empty_list {value=node; _} = *)
|
||||
(* let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in *)
|
||||
(* s_token lpar "("; *)
|
||||
(* s_token lbracket "["; *)
|
||||
(* s_token rbracket "]"; *)
|
||||
(* s_token colon ":"; *)
|
||||
(* s_type_expr type_expr; *)
|
||||
(* s_token rpar ")" *)
|
||||
|
||||
(* and s_set {value=node; _} = *)
|
||||
(* let lbrace, sequence, rbrace = node in *)
|
||||
(* s_token lbrace "{"; *)
|
||||
(* s_nsepseq "," s_expr sequence; *)
|
||||
(* s_token rbrace "}" *)
|
||||
|
||||
(* and s_empty_set {value=node; _} = *)
|
||||
(* let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in *)
|
||||
(* s_token lpar "("; *)
|
||||
(* s_token lbrace "{"; *)
|
||||
(* s_token rbrace "}"; *)
|
||||
(* s_token colon ":"; *)
|
||||
(* s_type_expr type_expr; *)
|
||||
(* s_token rpar ")" *)
|
||||
|
||||
(* and s_none_expr {value=node; _} = *)
|
||||
(* let lpar, (c_None, colon, type_expr), rpar = node in *)
|
||||
(* s_token lpar "("; *)
|
||||
(* s_token c_None "None"; *)
|
||||
(* s_token colon ":"; *)
|
||||
(* s_type_expr type_expr; *)
|
||||
(* s_token rpar ")" *)
|
||||
|
||||
(* and s_constr_app {value=node; _} = *)
|
||||
(* let constr, arguments = node in *)
|
||||
(* s_constr constr; *)
|
||||
(* s_tuple arguments *)
|
||||
|
||||
(* and s_some_app {value=node; _} = *)
|
||||
(* let c_Some, arguments = node in *)
|
||||
(* s_token c_Some "Some"; *)
|
||||
(* s_tuple arguments *)
|
||||
|
||||
|
||||
(* and s_par_expr {value=node; _} = *)
|
||||
(* let lpar, expr, rpar = node in *)
|
||||
(* s_token lpar "("; *)
|
||||
(* s_expr expr; *)
|
||||
(* s_token rpar ")" *)
|
||||
|
||||
(* and s_psome {value=node; _} = *)
|
||||
(* let c_Some, patterns = node in *)
|
||||
(* s_token c_Some "Some"; *)
|
||||
(* s_patterns patterns *)
|
||||
|
||||
|
||||
(* and s_terminator = function *)
|
||||
(* Some semi -> s_token semi ";" *)
|
||||
(* | None -> () *)
|
||||
3
src/ligo/parser/Error.mli
Normal file
3
src/ligo/parser/Error.mli
Normal file
@ -0,0 +1,3 @@
|
||||
type t = ..
|
||||
|
||||
type error = t
|
||||
149
src/ligo/parser/EvalOpt.ml
Normal file
149
src/ligo/parser/EvalOpt.ml
Normal file
@ -0,0 +1,149 @@
|
||||
(* Parsing the command-line option for testing the Ligo lexer and
|
||||
parser *)
|
||||
|
||||
let printf = Printf.printf
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
let abort msg =
|
||||
Utils.highlight (sprintf "Command-line error: %s\n" msg); exit 1
|
||||
|
||||
(* Help *)
|
||||
|
||||
let help () =
|
||||
let file = Filename.basename Sys.argv.(0) in
|
||||
printf "Usage: %s [<option> ...] [<input>.li | \"-\"]\n" file;
|
||||
print_endline "where <input>.li is the Ligo source file (default: stdin),";
|
||||
print_endline "and each <option> (if any) is one of the following:";
|
||||
print_endline " -c, --copy Print lexemes of tokens and markup (lexer)";
|
||||
print_endline " -t, --tokens Print tokens (lexer)";
|
||||
print_endline " -u, --units Print tokens and markup (lexer)";
|
||||
print_endline " -q, --quiet No output, except errors (default)";
|
||||
print_endline " --columns Columns for source locations";
|
||||
print_endline " --bytes Bytes for source locations";
|
||||
print_endline " --verbose=<stages> cmdline, ast";
|
||||
print_endline " --version Commit hash on stdout";
|
||||
print_endline " -h, --help This help";
|
||||
exit 0
|
||||
|
||||
(* Version *)
|
||||
|
||||
let version () = printf "%s\n" Version.version; exit 0
|
||||
|
||||
(* Specifying the command-line options a la GNU *)
|
||||
|
||||
let copy = ref false
|
||||
and tokens = ref false
|
||||
and units = ref false
|
||||
and quiet = ref false
|
||||
and columns = ref false
|
||||
and bytes = ref false
|
||||
and verbose = ref Utils.String.Set.empty
|
||||
and input = ref None
|
||||
|
||||
let split_at_colon = Str.(split (regexp ":"))
|
||||
|
||||
let add_verbose d =
|
||||
verbose := List.fold_left (Utils.swap Utils.String.Set.add)
|
||||
!verbose
|
||||
(split_at_colon d)
|
||||
|
||||
let specs =
|
||||
let open! Getopt in [
|
||||
'c', "copy", set copy true, None;
|
||||
't', "tokens", set tokens true, None;
|
||||
'u', "units", set units true, None;
|
||||
'q', "quiet", set quiet true, None;
|
||||
noshort, "columns", set columns true, None;
|
||||
noshort, "bytes", set bytes true, None;
|
||||
noshort, "verbose", None, Some add_verbose;
|
||||
'h', "help", Some help, None;
|
||||
noshort, "version", Some version, None
|
||||
]
|
||||
;;
|
||||
|
||||
(* Handler of anonymous arguments *)
|
||||
|
||||
let anonymous arg =
|
||||
match !input with
|
||||
None -> input := Some arg
|
||||
| Some _ -> abort (sprintf "Multiple inputs")
|
||||
;;
|
||||
|
||||
(* Parsing the command-line options *)
|
||||
|
||||
try Getopt.parse_cmdline specs anonymous with
|
||||
Getopt.Error msg -> abort msg
|
||||
;;
|
||||
|
||||
(* Checking options and exporting them as non-mutable values *)
|
||||
|
||||
type command = Quiet | Copy | Units | Tokens
|
||||
|
||||
let cmd =
|
||||
match !quiet, !copy, !units, !tokens with
|
||||
false, false, false, false
|
||||
| true, false, false, false -> Quiet
|
||||
| false, true, false, false -> Copy
|
||||
| false, false, true, false -> Units
|
||||
| false, false, false, true -> Tokens
|
||||
| _ -> abort "Choose one of -q, -c, -u, -t."
|
||||
|
||||
let string_of convert = function
|
||||
None -> "None"
|
||||
| Some s -> sprintf "Some %s" (convert s)
|
||||
|
||||
let quote s = sprintf "\"%s\"" s
|
||||
|
||||
let verbose_str =
|
||||
let apply e a =
|
||||
if a <> "" then sprintf "%s, %s" e a else e
|
||||
in Utils.String.Set.fold apply !verbose ""
|
||||
|
||||
let print_opt () =
|
||||
printf "COMMAND LINE\n";
|
||||
printf "copy = %b\n" !copy;
|
||||
printf "tokens = %b\n" !tokens;
|
||||
printf "units = %b\n" !units;
|
||||
printf "quiet = %b\n" !quiet;
|
||||
printf "columns = %b\n" !columns;
|
||||
printf "bytes = %b\n" !bytes;
|
||||
printf "verbose = \"%s\"\n" verbose_str;
|
||||
printf "input = %s\n" (string_of quote !input)
|
||||
;;
|
||||
|
||||
if Utils.String.Set.mem "cmdline" !verbose then print_opt ();;
|
||||
|
||||
let input =
|
||||
match !input with
|
||||
None | Some "-" -> !input
|
||||
| Some file_path ->
|
||||
if Filename.check_suffix file_path ".li"
|
||||
then if Sys.file_exists file_path
|
||||
then Some file_path
|
||||
else abort "Source file not found."
|
||||
else abort "Source file lacks the extension .li."
|
||||
|
||||
(* Exporting remaining options as non-mutable values *)
|
||||
|
||||
let copy = !copy
|
||||
and tokens = !tokens
|
||||
and units = !units
|
||||
and quiet = !quiet
|
||||
and offsets = not !columns
|
||||
and mode = if !bytes then `Byte else `Point
|
||||
and verbose = !verbose
|
||||
;;
|
||||
|
||||
if Utils.String.Set.mem "cmdline" verbose then
|
||||
begin
|
||||
printf "\nEXPORTED COMMAND LINE\n";
|
||||
printf "copy = %b\n" copy;
|
||||
printf "tokens = %b\n" tokens;
|
||||
printf "units = %b\n" units;
|
||||
printf "quiet = %b\n" quiet;
|
||||
printf "offsets = %b\n" offsets;
|
||||
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
|
||||
printf "verbose = \"%s\"\n" verbose_str;
|
||||
printf "input = %s\n" (string_of quote input)
|
||||
end
|
||||
;;
|
||||
42
src/ligo/parser/EvalOpt.mli
Normal file
42
src/ligo/parser/EvalOpt.mli
Normal file
@ -0,0 +1,42 @@
|
||||
(* Parsing the command-line option for testing the Ligo lexer and
|
||||
parser *)
|
||||
|
||||
(* If the value [offsets] is [true], then the user requested that
|
||||
messages about source positions and regions be expressed in terms
|
||||
of horizontal offsets. *)
|
||||
|
||||
val offsets : bool
|
||||
|
||||
(* 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. *)
|
||||
|
||||
val mode : [`Byte | `Point]
|
||||
|
||||
(* If the option [verbose] is set to a list of predefined stages of
|
||||
the compiler chain, then more information may be displayed about
|
||||
those stages. *)
|
||||
|
||||
val verbose : Utils.String.Set.t
|
||||
|
||||
(* If the value [input] is [None] or [Some "-"], the input is standard
|
||||
input. If [Some f], then the input is the file whose name (file
|
||||
path) is [f]. *)
|
||||
|
||||
val input : string option
|
||||
|
||||
(* If the value [cmd] is
|
||||
* [Quiet], then no output from the lexer and parser should be
|
||||
expected, safe error messages: this is the default value;
|
||||
* [Copy], then lexemes of tokens and markup will be printed to
|
||||
standard output, with the expectation of a perfect match with
|
||||
the input file;
|
||||
* [Units], then the tokens and markup will be printed to standard
|
||||
output, that is, the abstract representation of the concrete
|
||||
lexical syntax;
|
||||
* [Tokens], then the tokens only will be printed.
|
||||
*)
|
||||
|
||||
type command = Quiet | Copy | Units | Tokens
|
||||
|
||||
val cmd : command
|
||||
19
src/ligo/parser/FQueue.ml
Normal file
19
src/ligo/parser/FQueue.ml
Normal file
@ -0,0 +1,19 @@
|
||||
(* Purely functional queues based on a pair of lists *)
|
||||
|
||||
type 'a t = {rear: 'a list; front: 'a list}
|
||||
|
||||
let empty = {rear=[]; front=[]}
|
||||
|
||||
let enq x q = {q with rear = x::q.rear}
|
||||
|
||||
let rec deq = function
|
||||
{rear=[]; front= []} -> None
|
||||
| {rear; front= []} -> deq {rear=[]; front = List.rev rear}
|
||||
| {rear; front=x::f} -> Some ({rear; front=f}, x)
|
||||
|
||||
let rec peek = function
|
||||
{rear=[]; front= []} -> None
|
||||
| {rear; front= []} -> peek {rear=[]; front = List.rev rear}
|
||||
| {rear=_; front=x::_} as q -> Some (q,x)
|
||||
|
||||
let is_empty q = (q = empty)
|
||||
17
src/ligo/parser/FQueue.mli
Normal file
17
src/ligo/parser/FQueue.mli
Normal file
@ -0,0 +1,17 @@
|
||||
(* Purely functional queues *)
|
||||
|
||||
type 'a t
|
||||
|
||||
val empty : 'a t
|
||||
val enq : 'a -> 'a t -> 'a t
|
||||
val deq : 'a t -> ('a t * 'a) option
|
||||
|
||||
val is_empty : 'a t -> bool
|
||||
|
||||
(* The call [peek q] is [None] if the queue [q] is empty, and,
|
||||
otherwise, is a pair made of a queue and the next item in it to be
|
||||
dequeued. The returned queue contains the same items as [q], in the
|
||||
same order, but more efficient, in general, to use in further
|
||||
calls. *)
|
||||
|
||||
val peek : 'a t -> ('a t * 'a) option
|
||||
150
src/ligo/parser/LexToken.mli
Normal file
150
src/ligo/parser/LexToken.mli
Normal file
@ -0,0 +1,150 @@
|
||||
(* This signature defines the lexical tokens for Ligo
|
||||
|
||||
_Tokens_ are the abstract units which are used by the parser to
|
||||
build the abstract syntax tree (AST), in other words, the stream of
|
||||
tokens is the minimal model of the input program, carrying
|
||||
implicitly all its structure in a linear encoding, and nothing
|
||||
else, in particular, comments and whitespace are absent.
|
||||
|
||||
A _lexeme_ is a specific character string (concrete
|
||||
representation) denoting a token (abstract representation). Tokens
|
||||
can be thought of as sets, and lexemes as elements of those sets --
|
||||
there is often an infinite number of lexemes, but a small number of
|
||||
tokens. (Think of identifiers as lexemes and one token.)
|
||||
|
||||
The tokens are qualified here as being "lexical" because the
|
||||
parser generator Menhir expects to define them, in which context
|
||||
they are called "parsing tokens", and they are made to match each
|
||||
other. (This is an idiosyncratic terminology.)
|
||||
|
||||
The type of the lexical tokens is the variant [t], also
|
||||
aliased to [token].
|
||||
*)
|
||||
|
||||
type lexeme = string
|
||||
|
||||
(* TOKENS *)
|
||||
|
||||
type t =
|
||||
(* Literals *)
|
||||
|
||||
String of lexeme Region.reg
|
||||
| Bytes of (lexeme * MBytes.t) Region.reg
|
||||
| Int of (lexeme * Z.t) Region.reg
|
||||
| Ident of lexeme Region.reg
|
||||
| Constr of lexeme Region.reg
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
| SEMI of Region.t (* ";" *)
|
||||
| COMMA of Region.t (* "," *)
|
||||
| LPAR of Region.t (* "(" *)
|
||||
| RPAR of Region.t (* ")" *)
|
||||
| LBRACE of Region.t (* "{" *)
|
||||
| RBRACE of Region.t (* "}" *)
|
||||
| LBRACKET of Region.t (* "[" *)
|
||||
| RBRACKET of Region.t (* "]" *)
|
||||
| CONS of Region.t (* "#" *)
|
||||
| VBAR of Region.t (* "|" *)
|
||||
| ARROW of Region.t (* "->" *)
|
||||
| ASS of Region.t (* ":=" *)
|
||||
| EQUAL of Region.t (* "=" *)
|
||||
| COLON of Region.t (* ":" *)
|
||||
| OR of Region.t (* "||" *)
|
||||
| AND of Region.t (* "&&" *)
|
||||
| LT of Region.t (* "<" *)
|
||||
| LEQ of Region.t (* "<=" *)
|
||||
| GT of Region.t (* ">" *)
|
||||
| GEQ of Region.t (* ">=" *)
|
||||
| NEQ of Region.t (* "=/=" *)
|
||||
| PLUS of Region.t (* "+" *)
|
||||
| MINUS of Region.t (* "-" *)
|
||||
| SLASH of Region.t (* "/" *)
|
||||
| TIMES of Region.t (* "*" *)
|
||||
| DOT of Region.t (* "." *)
|
||||
| WILD of Region.t (* "_" *)
|
||||
| CAT of Region.t (* "^" *)
|
||||
|
||||
(* Keywords *)
|
||||
|
||||
| Begin of Region.t (* "begin" *)
|
||||
| Const of Region.t (* "const" *)
|
||||
| Down of Region.t (* "down" *)
|
||||
| Fail of Region.t (* "fail" *)
|
||||
| If of Region.t (* "if" *)
|
||||
| In of Region.t (* "in" *)
|
||||
| Is of Region.t (* "is" *)
|
||||
| Entrypoint of Region.t (* "entrypoint" *)
|
||||
| For of Region.t (* "for" *)
|
||||
| Function of Region.t (* "function" *)
|
||||
| Storage of Region.t (* "storage" *)
|
||||
| Type of Region.t (* "type" *)
|
||||
| Of of Region.t (* "of" *)
|
||||
| Operations of Region.t (* "operations" *)
|
||||
| Var of Region.t (* "var" *)
|
||||
| End of Region.t (* "end" *)
|
||||
| Then of Region.t (* "then" *)
|
||||
| Else of Region.t (* "else" *)
|
||||
| Match of Region.t (* "match" *)
|
||||
| Null of Region.t (* "null" *)
|
||||
| Procedure of Region.t (* "procedure" *)
|
||||
| Record of Region.t (* "record" *)
|
||||
| Step of Region.t (* "step" *)
|
||||
| To of Region.t (* "to" *)
|
||||
| Mod of Region.t (* "mod" *)
|
||||
| Not of Region.t (* "not" *)
|
||||
| While of Region.t (* "while" *)
|
||||
| With of Region.t (* "with" *)
|
||||
|
||||
(* Data constructors *)
|
||||
|
||||
| C_False of Region.t (* "False" *)
|
||||
| C_None of Region.t (* "None" *)
|
||||
| C_Some of Region.t (* "Some" *)
|
||||
| C_True of Region.t (* "True" *)
|
||||
| C_Unit of Region.t (* "Unit" *)
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
| EOF of Region.t
|
||||
|
||||
|
||||
type token = t
|
||||
|
||||
(* Projections
|
||||
|
||||
The difference between extracting the lexeme and a string from a
|
||||
token is that the latter is the textual representation of the OCaml
|
||||
value denoting the token (its abstract syntax), rather than its
|
||||
lexeme (concrete syntax).
|
||||
*)
|
||||
|
||||
val to_lexeme : token -> lexeme
|
||||
val to_string : token -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
val to_region : token -> Region.t
|
||||
|
||||
(* Injections *)
|
||||
|
||||
type int_err =
|
||||
Non_canonical_zero
|
||||
|
||||
type ident_err = Reserved_name
|
||||
|
||||
val mk_string : lexeme -> Region.t -> token
|
||||
val mk_bytes : lexeme -> Region.t -> token
|
||||
val mk_int : lexeme -> Region.t -> (token, int_err) result
|
||||
val mk_ident : lexeme -> Region.t -> (token, ident_err) result
|
||||
val mk_constr : lexeme -> Region.t -> token
|
||||
val mk_sym : lexeme -> Region.t -> token
|
||||
val eof : Region.t -> token
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
val is_string : token -> bool
|
||||
val is_bytes : token -> bool
|
||||
val is_int : token -> bool
|
||||
val is_ident : token -> bool
|
||||
val is_kwd : token -> bool
|
||||
val is_constr : token -> bool
|
||||
val is_sym : token -> bool
|
||||
val is_eof : token -> bool
|
||||
621
src/ligo/parser/LexToken.mll
Normal file
621
src/ligo/parser/LexToken.mll
Normal file
@ -0,0 +1,621 @@
|
||||
(* Lexer specification for Ligo, to be processed by [ocamllex] *)
|
||||
|
||||
{
|
||||
(* START HEADER *)
|
||||
|
||||
(* Shorthands *)
|
||||
|
||||
type lexeme = string
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
module SMap = Utils.String.Map
|
||||
module SSet = Utils.String.Set
|
||||
|
||||
(* Hack to roll back one lexeme in the current semantic action *)
|
||||
(*
|
||||
let rollback buffer =
|
||||
let open Lexing in
|
||||
let len = String.length (lexeme buffer) in
|
||||
let pos_cnum = buffer.lex_curr_p.pos_cnum - len in
|
||||
buffer.lex_curr_pos <- buffer.lex_curr_pos - len;
|
||||
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_cnum}
|
||||
*)
|
||||
|
||||
(* TOKENS *)
|
||||
|
||||
type t =
|
||||
(* Literals *)
|
||||
|
||||
String of lexeme Region.reg
|
||||
| Bytes of (lexeme * MBytes.t) Region.reg
|
||||
| Int of (lexeme * Z.t) Region.reg
|
||||
| Ident of lexeme Region.reg
|
||||
| Constr of lexeme Region.reg
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
| SEMI of Region.t
|
||||
| COMMA of Region.t
|
||||
| LPAR of Region.t
|
||||
| RPAR of Region.t
|
||||
| LBRACE of Region.t
|
||||
| RBRACE of Region.t
|
||||
| LBRACKET of Region.t
|
||||
| RBRACKET of Region.t
|
||||
| CONS of Region.t
|
||||
| VBAR of Region.t
|
||||
| ARROW of Region.t
|
||||
| ASS of Region.t
|
||||
| EQUAL of Region.t
|
||||
| COLON of Region.t
|
||||
| OR of Region.t
|
||||
| AND of Region.t
|
||||
| LT of Region.t
|
||||
| LEQ of Region.t
|
||||
| GT of Region.t
|
||||
| GEQ of Region.t
|
||||
| NEQ of Region.t
|
||||
| PLUS of Region.t
|
||||
| MINUS of Region.t
|
||||
| SLASH of Region.t
|
||||
| TIMES of Region.t
|
||||
| DOT of Region.t
|
||||
| WILD of Region.t
|
||||
| CAT of Region.t
|
||||
|
||||
(* Keywords *)
|
||||
|
||||
| Begin of Region.t
|
||||
| Const of Region.t
|
||||
| Down of Region.t
|
||||
| Fail of Region.t
|
||||
| If of Region.t
|
||||
| In of Region.t
|
||||
| Is of Region.t
|
||||
| Entrypoint of Region.t
|
||||
| For of Region.t
|
||||
| Function of Region.t
|
||||
| Storage of Region.t
|
||||
| Type of Region.t
|
||||
| Of of Region.t
|
||||
| Operations of Region.t
|
||||
| Var of Region.t
|
||||
| End of Region.t
|
||||
| Then of Region.t
|
||||
| Else of Region.t
|
||||
| Match of Region.t
|
||||
| Null of Region.t
|
||||
| Procedure of Region.t
|
||||
| Record of Region.t
|
||||
| Step of Region.t
|
||||
| To of Region.t
|
||||
| Mod of Region.t
|
||||
| Not of Region.t
|
||||
| While of Region.t
|
||||
| With of Region.t
|
||||
|
||||
(* Types *)
|
||||
(*
|
||||
| T_address of Region.t (* "address" *)
|
||||
| T_big_map of Region.t (* "big_map" *)
|
||||
| T_bool of Region.t (* "bool" *)
|
||||
| T_bytes of Region.t (* "bytes" *)
|
||||
| T_contract of Region.t (* "contract" *)
|
||||
| T_int of Region.t (* "int" *)
|
||||
| T_key of Region.t (* "key" *)
|
||||
| T_key_hash of Region.t (* "key_hash" *)
|
||||
| T_list of Region.t (* "list" *)
|
||||
| T_map of Region.t (* "map" *)
|
||||
| T_mutez of Region.t (* "mutez" *)
|
||||
| T_nat of Region.t (* "nat" *)
|
||||
| T_operation of Region.t (* "operation" *)
|
||||
| T_option of Region.t (* "option" *)
|
||||
| T_set of Region.t (* "set" *)
|
||||
| T_signature of Region.t (* "signature" *)
|
||||
| T_string of Region.t (* "string" *)
|
||||
| T_timestamp of Region.t (* "timestamp" *)
|
||||
| T_unit of Region.t (* "unit" *)
|
||||
*)
|
||||
(* Data constructors *)
|
||||
|
||||
| C_False of Region.t (* "False" *)
|
||||
| C_None of Region.t (* "None" *)
|
||||
| C_Some of Region.t (* "Some" *)
|
||||
| C_True of Region.t (* "True" *)
|
||||
| C_Unit of Region.t (* "Unit" *)
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
| EOF of Region.t
|
||||
|
||||
|
||||
type token = t
|
||||
|
||||
let proj_token = function
|
||||
(* Literals *)
|
||||
|
||||
String Region.{region; value} ->
|
||||
region, sprintf "String %s" value
|
||||
|
||||
| Bytes Region.{region; value = s,b} ->
|
||||
region,
|
||||
sprintf "Bytes (\"%s\", \"0x%s\")"
|
||||
s (MBytes.to_hex b |> Hex.to_string)
|
||||
|
||||
| Int Region.{region; value = s,n} ->
|
||||
region, sprintf "Int (\"%s\", %s)" s (Z.to_string n)
|
||||
|
||||
| Ident Region.{region; value} ->
|
||||
region, sprintf "Ident \"%s\"" value
|
||||
|
||||
| Constr Region.{region; value} ->
|
||||
region, sprintf "Constr \"%s\"" value
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
| SEMI region -> region, "SEMI"
|
||||
| COMMA region -> region, "COMMA"
|
||||
| LPAR region -> region, "LPAR"
|
||||
| RPAR region -> region, "RPAR"
|
||||
| LBRACE region -> region, "LBRACE"
|
||||
| RBRACE region -> region, "RBRACE"
|
||||
| LBRACKET region -> region, "LBRACKET"
|
||||
| RBRACKET region -> region, "RBRACKET"
|
||||
| CONS region -> region, "CONS"
|
||||
| VBAR region -> region, "VBAR"
|
||||
| ARROW region -> region, "ARROW"
|
||||
| ASS region -> region, "ASS"
|
||||
| EQUAL region -> region, "EQUAL"
|
||||
| COLON region -> region, "COLON"
|
||||
| OR region -> region, "OR"
|
||||
| AND region -> region, "AND"
|
||||
| LT region -> region, "LT"
|
||||
| LEQ region -> region, "LEQ"
|
||||
| GT region -> region, "GT"
|
||||
| GEQ region -> region, "GEQ"
|
||||
| NEQ region -> region, "NEQ"
|
||||
| PLUS region -> region, "PLUS"
|
||||
| MINUS region -> region, "MINUS"
|
||||
| SLASH region -> region, "SLASH"
|
||||
| TIMES region -> region, "TIMES"
|
||||
| DOT region -> region, "DOT"
|
||||
| WILD region -> region, "WILD"
|
||||
| CAT region -> region, "CAT"
|
||||
|
||||
(* Keywords *)
|
||||
|
||||
| Begin region -> region, "Begin"
|
||||
| Const region -> region, "Const"
|
||||
| Down region -> region, "Down"
|
||||
| Fail region -> region, "Fail"
|
||||
| If region -> region, "If"
|
||||
| In region -> region, "In"
|
||||
| Is region -> region, "Is"
|
||||
| Entrypoint region -> region, "Entrypoint"
|
||||
| For region -> region, "For"
|
||||
| Function region -> region, "Function"
|
||||
| Storage region -> region, "Storage"
|
||||
| Type region -> region, "Type"
|
||||
| Of region -> region, "Of"
|
||||
| Operations region -> region, "Operations"
|
||||
| Var region -> region, "Var"
|
||||
| End region -> region, "End"
|
||||
| Then region -> region, "Then"
|
||||
| Else region -> region, "Else"
|
||||
| Match region -> region, "Match"
|
||||
| Null region -> region, "Null"
|
||||
| Procedure region -> region, "Procedure"
|
||||
| Record region -> region, "Record"
|
||||
| Step region -> region, "Step"
|
||||
| To region -> region, "To"
|
||||
| Mod region -> region, "Mod"
|
||||
| Not region -> region, "Not"
|
||||
| While region -> region, "While"
|
||||
| With region -> region, "With"
|
||||
|
||||
(* Data *)
|
||||
|
||||
| C_False region -> region, "C_False"
|
||||
| C_None region -> region, "C_None"
|
||||
| C_Some region -> region, "C_Some"
|
||||
| C_True region -> region, "C_True"
|
||||
| C_Unit region -> region, "C_Unit"
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
| EOF region -> region, "EOF"
|
||||
|
||||
|
||||
let to_lexeme = function
|
||||
(* Literals *)
|
||||
|
||||
String s -> s.Region.value
|
||||
| Bytes b -> fst b.Region.value
|
||||
| Int i -> fst i.Region.value
|
||||
| Ident id
|
||||
| Constr id -> id.Region.value
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
| SEMI _ -> ";"
|
||||
| COMMA _ -> ","
|
||||
| LPAR _ -> "("
|
||||
| RPAR _ -> ")"
|
||||
| LBRACE _ -> "{"
|
||||
| RBRACE _ -> "}"
|
||||
| LBRACKET _ -> "["
|
||||
| RBRACKET _ -> "]"
|
||||
| CONS _ -> "#"
|
||||
| VBAR _ -> "|"
|
||||
| ARROW _ -> "->"
|
||||
| ASS _ -> ":="
|
||||
| EQUAL _ -> "="
|
||||
| COLON _ -> ":"
|
||||
| OR _ -> "||"
|
||||
| AND _ -> "&&"
|
||||
| LT _ -> "<"
|
||||
| LEQ _ -> "<="
|
||||
| GT _ -> ">"
|
||||
| GEQ _ -> ">="
|
||||
| NEQ _ -> "=/="
|
||||
| PLUS _ -> "+"
|
||||
| MINUS _ -> "-"
|
||||
| SLASH _ -> "/"
|
||||
| TIMES _ -> "*"
|
||||
| DOT _ -> "."
|
||||
| WILD _ -> "_"
|
||||
| CAT _ -> "^"
|
||||
|
||||
(* Keywords *)
|
||||
|
||||
| Begin _ -> "begin"
|
||||
| Const _ -> "const"
|
||||
| Down _ -> "down"
|
||||
| Fail _ -> "fail"
|
||||
| If _ -> "if"
|
||||
| In _ -> "in"
|
||||
| Is _ -> "is"
|
||||
| Entrypoint _ -> "entrypoint"
|
||||
| For _ -> "for"
|
||||
| Function _ -> "function"
|
||||
| Storage _ -> "storage"
|
||||
| Type _ -> "type"
|
||||
| Of _ -> "of"
|
||||
| Operations _ -> "operations"
|
||||
| Var _ -> "var"
|
||||
| End _ -> "end"
|
||||
| Then _ -> "then"
|
||||
| Else _ -> "else"
|
||||
| Match _ -> "match"
|
||||
| Null _ -> "null"
|
||||
| Procedure _ -> "procedure"
|
||||
| Record _ -> "record"
|
||||
| Step _ -> "step"
|
||||
| To _ -> "to"
|
||||
| Mod _ -> "mod"
|
||||
| Not _ -> "not"
|
||||
| While _ -> "while"
|
||||
| With _ -> "with"
|
||||
|
||||
(* Data constructors *)
|
||||
|
||||
| C_False _ -> "False"
|
||||
| C_None _ -> "None"
|
||||
| C_Some _ -> "Some"
|
||||
| C_True _ -> "True"
|
||||
| C_Unit _ -> "Unit"
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
| EOF _ -> ""
|
||||
|
||||
|
||||
let to_string token ?(offsets=true) mode =
|
||||
let region, val_str = proj_token token in
|
||||
let reg_str = region#compact ~offsets mode
|
||||
in sprintf "%s: %s" reg_str val_str
|
||||
|
||||
let to_region token = proj_token token |> fst
|
||||
|
||||
(* LEXIS *)
|
||||
|
||||
let keywords = [
|
||||
(fun reg -> Begin reg);
|
||||
(fun reg -> Const reg);
|
||||
(fun reg -> Down reg);
|
||||
(fun reg -> Fail reg);
|
||||
(fun reg -> If reg);
|
||||
(fun reg -> In reg);
|
||||
(fun reg -> Is reg);
|
||||
(fun reg -> Entrypoint reg);
|
||||
(fun reg -> For reg);
|
||||
(fun reg -> Function reg);
|
||||
(fun reg -> Storage reg);
|
||||
(fun reg -> Type reg);
|
||||
(fun reg -> Of reg);
|
||||
(fun reg -> Operations reg);
|
||||
(fun reg -> Var reg);
|
||||
(fun reg -> End reg);
|
||||
(fun reg -> Then reg);
|
||||
(fun reg -> Else reg);
|
||||
(fun reg -> Match reg);
|
||||
(fun reg -> Null reg);
|
||||
(fun reg -> Procedure reg);
|
||||
(fun reg -> Record reg);
|
||||
(fun reg -> Step reg);
|
||||
(fun reg -> To reg);
|
||||
(fun reg -> Mod reg);
|
||||
(fun reg -> Not reg);
|
||||
(fun reg -> While reg);
|
||||
(fun reg -> With reg)
|
||||
]
|
||||
|
||||
let reserved =
|
||||
let open SSet in
|
||||
empty |> add "and"
|
||||
|> add "as"
|
||||
|> add "asr"
|
||||
|> add "assert"
|
||||
|> add "class"
|
||||
|> add "constraint"
|
||||
|> add "do"
|
||||
|> add "done"
|
||||
|> add "downto"
|
||||
|> add "exception"
|
||||
|> add "external"
|
||||
|> add "false"
|
||||
|> add "fun"
|
||||
|> add "functor"
|
||||
|> add "include"
|
||||
|> add "inherit"
|
||||
|> add "initializer"
|
||||
|> add "land"
|
||||
|> add "lazy"
|
||||
|> add "let"
|
||||
|> add "lor"
|
||||
|> add "lsl"
|
||||
|> add "lsr"
|
||||
|> add "lxor"
|
||||
|> add "method"
|
||||
|> add "module"
|
||||
|> add "mutable"
|
||||
|> add "new"
|
||||
|> add "nonrec"
|
||||
|> add "object"
|
||||
|> add "open"
|
||||
|> add "or"
|
||||
|> add "private"
|
||||
|> add "rec"
|
||||
|> add "sig"
|
||||
|> add "struct"
|
||||
|> add "true"
|
||||
|> add "try"
|
||||
|> add "val"
|
||||
|> add "virtual"
|
||||
|> add "when"
|
||||
|
||||
let constructors = [
|
||||
(fun reg -> C_False reg);
|
||||
(fun reg -> C_None reg);
|
||||
(fun reg -> C_Some reg);
|
||||
(fun reg -> C_True reg);
|
||||
(fun reg -> C_Unit reg)
|
||||
]
|
||||
|
||||
let add map (key, value) = SMap.add key value map
|
||||
|
||||
let mk_map mk_key list =
|
||||
let apply map value = add map (mk_key value, value)
|
||||
in List.fold_left apply SMap.empty list
|
||||
|
||||
type lexis = {
|
||||
kwd : (Region.t -> token) SMap.t;
|
||||
cstr : (Region.t -> token) SMap.t;
|
||||
res : SSet.t
|
||||
}
|
||||
|
||||
let lexicon : lexis =
|
||||
let build list = mk_map (fun f -> to_lexeme (f Region.ghost)) list
|
||||
in {kwd = build keywords;
|
||||
cstr = build constructors;
|
||||
res = reserved}
|
||||
|
||||
(* Identifiers *)
|
||||
|
||||
type ident_err = Reserved_name
|
||||
|
||||
(* END HEADER *)
|
||||
}
|
||||
|
||||
(* START LEXER DEFINITION *)
|
||||
|
||||
(* Named regular expressions *)
|
||||
|
||||
let small = ['a'-'z']
|
||||
let capital = ['A'-'Z']
|
||||
let letter = small | capital
|
||||
let digit = ['0'-'9']
|
||||
let ident = small (letter | '_' | digit)*
|
||||
let constr = capital (letter | '_' | digit)*
|
||||
|
||||
(* Rules *)
|
||||
|
||||
rule scan_ident region lexicon = parse
|
||||
(ident as value) eof {
|
||||
if SSet.mem value lexicon.res
|
||||
then Error Reserved_name
|
||||
else Ok (match SMap.find_opt value lexicon.kwd with
|
||||
Some mk_kwd -> mk_kwd region
|
||||
| None -> Ident Region.{region; value}) }
|
||||
|
||||
and scan_constr region lexicon = parse
|
||||
(constr as value) eof {
|
||||
match SMap.find_opt value lexicon.cstr with
|
||||
Some mk_cstr -> mk_cstr region
|
||||
| None -> Constr Region.{region; value} }
|
||||
|
||||
(* END LEXER DEFINITION *)
|
||||
|
||||
{
|
||||
(* START TRAILER *)
|
||||
|
||||
(* Smart constructors (injections) *)
|
||||
|
||||
let mk_string lexeme region = String Region.{region; value=lexeme}
|
||||
|
||||
let mk_bytes lexeme region =
|
||||
let norm = Str.(global_replace (regexp "_") "" lexeme) in
|
||||
let value = lexeme, MBytes.of_hex (Hex.of_string norm)
|
||||
in Bytes Region.{region; value}
|
||||
|
||||
type int_err = Non_canonical_zero
|
||||
|
||||
let mk_int lexeme region =
|
||||
let z = Str.(global_replace (regexp "_") "" lexeme)
|
||||
|> Z.of_string in
|
||||
if Z.equal z Z.zero && lexeme <> "0"
|
||||
then Error Non_canonical_zero
|
||||
else Ok (Int Region.{region; value = lexeme, z})
|
||||
|
||||
let eof region = EOF region
|
||||
|
||||
let mk_sym lexeme region =
|
||||
match lexeme with
|
||||
";" -> SEMI region
|
||||
| "," -> COMMA region
|
||||
| "(" -> LPAR region
|
||||
| ")" -> RPAR region
|
||||
| "{" -> LBRACE region
|
||||
| "}" -> RBRACE region
|
||||
| "[" -> LBRACKET region
|
||||
| "]" -> RBRACKET region
|
||||
| "#" -> CONS region
|
||||
| "|" -> VBAR region
|
||||
| "->" -> ARROW region
|
||||
| ":=" -> ASS region
|
||||
| "=" -> EQUAL region
|
||||
| ":" -> COLON region
|
||||
| "||" -> OR region
|
||||
| "&&" -> AND region
|
||||
| "<" -> LT region
|
||||
| "<=" -> LEQ region
|
||||
| ">" -> GT region
|
||||
| ">=" -> GEQ region
|
||||
| "=/=" -> NEQ region
|
||||
| "+" -> PLUS region
|
||||
| "-" -> MINUS region
|
||||
| "/" -> SLASH region
|
||||
| "*" -> TIMES region
|
||||
| "." -> DOT region
|
||||
| "_" -> WILD region
|
||||
| "^" -> CAT region
|
||||
| _ -> assert false
|
||||
|
||||
(* Identifiers *)
|
||||
|
||||
let mk_ident' lexeme region lexicon =
|
||||
Lexing.from_string lexeme |> scan_ident region lexicon
|
||||
|
||||
let mk_ident lexeme region = mk_ident' lexeme region lexicon
|
||||
|
||||
(* Constructors *)
|
||||
|
||||
let mk_constr' lexeme region lexicon =
|
||||
Lexing.from_string lexeme |> scan_constr region lexicon
|
||||
|
||||
let mk_constr lexeme region = mk_constr' lexeme region lexicon
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
let is_string = function
|
||||
String _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_bytes = function
|
||||
Bytes _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_int = function
|
||||
Int _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_ident = function
|
||||
Ident _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_kwd = function
|
||||
| Begin _
|
||||
| Const _
|
||||
| Down _
|
||||
| Fail _
|
||||
| If _
|
||||
| In _
|
||||
| Is _
|
||||
| Entrypoint _
|
||||
| For _
|
||||
| Function _
|
||||
| Storage _
|
||||
| Type _
|
||||
| Of _
|
||||
| Operations _
|
||||
| Var _
|
||||
| End _
|
||||
| Then _
|
||||
| Else _
|
||||
| Match _
|
||||
| Null _
|
||||
| Procedure _
|
||||
| Record _
|
||||
| Step _
|
||||
| To _
|
||||
| Mod _
|
||||
| Not _
|
||||
| While _
|
||||
| With _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_constr = function
|
||||
Constr _
|
||||
| C_False _
|
||||
| C_None _
|
||||
| C_Some _
|
||||
| C_True _
|
||||
| C_Unit _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_sym = function
|
||||
SEMI _
|
||||
| COMMA _
|
||||
| LPAR _
|
||||
| RPAR _
|
||||
| LBRACE _
|
||||
| RBRACE _
|
||||
| LBRACKET _
|
||||
| RBRACKET _
|
||||
| CONS _
|
||||
| VBAR _
|
||||
| ARROW _
|
||||
| ASS _
|
||||
| EQUAL _
|
||||
| COLON _
|
||||
| OR _
|
||||
| AND _
|
||||
| LT _
|
||||
| LEQ _
|
||||
| GT _
|
||||
| GEQ _
|
||||
| NEQ _
|
||||
| PLUS _
|
||||
| MINUS _
|
||||
| SLASH _
|
||||
| TIMES _
|
||||
| DOT _
|
||||
| WILD _
|
||||
| CAT _ -> true
|
||||
| _ -> false
|
||||
|
||||
let is_eof = function EOF _ -> true | _ -> false
|
||||
|
||||
(* END TRAILER *)
|
||||
}
|
||||
153
src/ligo/parser/Lexer.mli
Normal file
153
src/ligo/parser/Lexer.mli
Normal file
@ -0,0 +1,153 @@
|
||||
(* Lexer specification for Ligo, to be processed by [ocamllex].
|
||||
|
||||
The underlying design principles are:
|
||||
|
||||
(1) enforce stylistic constraints at a lexical level, in order to
|
||||
early reject potentially misleading or poorly written
|
||||
Ligo contracts;
|
||||
|
||||
(2) provide precise error messages with hint as how to fix the
|
||||
issue, which is achieved by consulting the lexical
|
||||
right-context of lexemes;
|
||||
|
||||
(3) be as independent as possible from the Ligo version, so
|
||||
upgrades have as little impact as possible on this
|
||||
specification: this is achieved by using the most general
|
||||
regular expressions to match the lexing buffer and broadly
|
||||
distinguish the syntactic categories, and then delegating a
|
||||
finer, protocol-dependent, second analysis to an external
|
||||
module making the tokens (hence a functor below);
|
||||
|
||||
(4) support unit testing (lexing of the whole input with debug
|
||||
traces);
|
||||
|
||||
The limitation to the protocol independence lies in the errors that
|
||||
the external module building the tokens (which is
|
||||
protocol-dependent) may have to report. Indeed these errors have to
|
||||
be contextualised by the lexer in terms of input source regions, so
|
||||
useful error messages can be printed, therefore they are part of
|
||||
the signature [TOKEN] that parameterise the functor generated
|
||||
here. For instance, if, in a future release of Ligo, new tokens may
|
||||
be added, and the recognition of their lexemes may entail new
|
||||
errors, the signature [TOKEN] will have to be augmented and the
|
||||
lexer specification changed. However, it is more likely that
|
||||
instructions or types are added, instead of new kinds of tokens.
|
||||
*)
|
||||
|
||||
type lexeme = string
|
||||
|
||||
(* TOKENS *)
|
||||
|
||||
(* The signature [TOKEN] exports an abstract type [token], so a lexer
|
||||
can be a functor over tokens. This enables to externalise
|
||||
version-dependent constraints in any module whose signature matches
|
||||
[TOKEN]. Generic functions to construct tokens are required.
|
||||
|
||||
Note the predicate [is_eof], which caracterises the virtual token
|
||||
for end-of-file, because it requires special handling. Some of
|
||||
those functions may yield errors, which are defined as values of
|
||||
the type [int_err] etc. These errors can be better understood by
|
||||
reading the ocamllex specification for the lexer ([Lexer.mll]).
|
||||
*)
|
||||
|
||||
module type TOKEN =
|
||||
sig
|
||||
type token
|
||||
|
||||
(* Errors *)
|
||||
|
||||
type int_err = Non_canonical_zero
|
||||
type ident_err = Reserved_name
|
||||
|
||||
(* Injections *)
|
||||
|
||||
val mk_string : lexeme -> Region.t -> token
|
||||
val mk_bytes : lexeme -> Region.t -> token
|
||||
val mk_int : lexeme -> Region.t -> (token, int_err) result
|
||||
val mk_ident : lexeme -> Region.t -> (token, ident_err) result
|
||||
val mk_constr : lexeme -> Region.t -> token
|
||||
val mk_sym : lexeme -> Region.t -> token
|
||||
val eof : Region.t -> token
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
val is_string : token -> bool
|
||||
val is_bytes : token -> bool
|
||||
val is_int : token -> bool
|
||||
val is_ident : token -> bool
|
||||
val is_kwd : token -> bool
|
||||
val is_constr : token -> bool
|
||||
val is_sym : token -> bool
|
||||
val is_eof : token -> bool
|
||||
|
||||
(* Projections *)
|
||||
|
||||
val to_lexeme : token -> lexeme
|
||||
val to_string : token -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
val to_region : token -> Region.t
|
||||
end
|
||||
|
||||
(* The module type for lexers is [S]. It mainly exports the function
|
||||
[open_token_stream], which returns
|
||||
|
||||
* a function [read] that extracts tokens from a lexing buffer,
|
||||
* together with a lexing buffer [buffer] to read from,
|
||||
* a function [close] that closes that buffer,
|
||||
* a function [get_pos] that returns the current position, and
|
||||
* a function [get_last] that returns the region of the last
|
||||
recognised token.
|
||||
|
||||
Note that a module [Token] is exported too, because the signature
|
||||
of the exported functions depend on it.
|
||||
|
||||
The call [read ~log] evaluates in a lexer (a.k.a tokeniser or
|
||||
scanner) whose type is [Lexing.lexbuf -> token], and suitable for a
|
||||
parser generated by Menhir.
|
||||
|
||||
The argument labelled [log] is a logger. It may print a token and
|
||||
its left markup to a given channel, at the caller's discretion.
|
||||
*)
|
||||
|
||||
module type S =
|
||||
sig
|
||||
module Token : TOKEN
|
||||
type token = Token.token
|
||||
|
||||
type file_path = string
|
||||
type logger = Markup.t list -> token -> unit
|
||||
|
||||
val output_token :
|
||||
?offsets:bool -> [`Byte | `Point] ->
|
||||
EvalOpt.command -> out_channel -> logger
|
||||
|
||||
type instance = {
|
||||
read : ?log:logger -> Lexing.lexbuf -> token;
|
||||
buffer : Lexing.lexbuf;
|
||||
get_pos : unit -> Pos.t;
|
||||
get_last : unit -> Region.t;
|
||||
close : unit -> unit
|
||||
}
|
||||
|
||||
val open_token_stream : file_path option -> instance
|
||||
|
||||
(* Error reporting *)
|
||||
|
||||
exception Error of Error.t Region.reg
|
||||
|
||||
val print_error : ?offsets:bool -> [`Byte | `Point] ->
|
||||
Error.t Region.reg -> unit
|
||||
|
||||
(* Standalone tracer *)
|
||||
|
||||
val trace :
|
||||
?offsets:bool -> [`Byte | `Point] ->
|
||||
file_path option -> EvalOpt.command -> unit
|
||||
end
|
||||
|
||||
(* The functorised interface
|
||||
|
||||
Note that the module parameter [Token] is re-exported as a
|
||||
submodule in [S].
|
||||
*)
|
||||
|
||||
module Make (Token: TOKEN) : S with module Token = Token
|
||||
805
src/ligo/parser/Lexer.mll
Normal file
805
src/ligo/parser/Lexer.mll
Normal file
@ -0,0 +1,805 @@
|
||||
(* Lexer specification for Ligo, to be processed by [ocamllex]. *)
|
||||
|
||||
{
|
||||
(* START HEADER *)
|
||||
|
||||
type lexeme = string
|
||||
|
||||
(* STRING PROCESSING *)
|
||||
|
||||
(* The value of [mk_str len p] ("make string") is a string of length
|
||||
[len] containing the [len] characters in the list [p], in reverse
|
||||
order. For instance, [mk_str 3 ['c';'b';'a'] = "abc"]. *)
|
||||
|
||||
let mk_str (len: int) (p: char list) : string =
|
||||
let bytes = Bytes.make len ' ' in
|
||||
let rec fill i = function
|
||||
[] -> bytes
|
||||
| char::l -> Bytes.set bytes i char; fill (i-1) l
|
||||
in fill (len-1) p |> Bytes.to_string
|
||||
|
||||
(* The call [explode s a] is the list made by pushing the characters
|
||||
in the string [s] on top of [a], in reverse order. For example,
|
||||
[explode "ba" ['c';'d'] = ['a'; 'b'; 'c'; 'd']]. *)
|
||||
|
||||
let explode s acc =
|
||||
let rec push = function
|
||||
0 -> acc
|
||||
| i -> s.[i-1] :: push (i-1)
|
||||
in push (String.length s)
|
||||
|
||||
(* LEXER ENGINE *)
|
||||
|
||||
(* Resetting file name and line number in the lexing buffer
|
||||
|
||||
The call [reset ~file ~line buffer] modifies in-place the lexing
|
||||
buffer [buffer] so the lexing engine records that the file
|
||||
associated with [buffer] is named [file], and the current line is
|
||||
[line]. This function is useful when lexing a file that has been
|
||||
previously preprocessed by the C preprocessor, in which case the
|
||||
argument [file] is the name of the file that was preprocessed,
|
||||
_not_ the preprocessed file (of which the user is not normally
|
||||
aware). By default, the [line] argument is [1].
|
||||
*)
|
||||
|
||||
let reset_file ~file buffer =
|
||||
let open Lexing in
|
||||
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_fname = file}
|
||||
|
||||
let reset_line line_num buffer =
|
||||
let open Lexing in
|
||||
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_lnum = line_num}
|
||||
|
||||
let reset ~file ?(line=1) buffer =
|
||||
(* Default value per the [Lexing] standard module convention *)
|
||||
reset_file ~file buffer; reset_line line buffer
|
||||
|
||||
(* Rolling back one lexeme _within the current semantic action_ *)
|
||||
|
||||
let rollback buffer =
|
||||
let open Lexing in
|
||||
let len = String.length (lexeme buffer) in
|
||||
let pos_cnum = buffer.lex_curr_p.pos_cnum - len in
|
||||
buffer.lex_curr_pos <- buffer.lex_curr_pos - len;
|
||||
buffer.lex_curr_p <- {buffer.lex_curr_p with pos_cnum}
|
||||
|
||||
(* ALIASES *)
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
(* TOKENS *)
|
||||
|
||||
(* The signature [TOKEN] exports an abstract type [token], so a lexer
|
||||
can be a functor over tokens. Consequently, generic functions to
|
||||
construct tokens are provided. Note predicate [is_eof], which
|
||||
caracterises the virtual token for end-of-file, because it requires
|
||||
special handling. *)
|
||||
|
||||
module type TOKEN =
|
||||
sig
|
||||
type token
|
||||
|
||||
(* Errors *)
|
||||
|
||||
type int_err = Non_canonical_zero
|
||||
type ident_err = Reserved_name
|
||||
|
||||
(* Injections *)
|
||||
|
||||
val mk_string : lexeme -> Region.t -> token
|
||||
val mk_bytes : lexeme -> Region.t -> token
|
||||
val mk_int : lexeme -> Region.t -> (token, int_err) result
|
||||
val mk_ident : lexeme -> Region.t -> (token, ident_err) result
|
||||
val mk_constr : lexeme -> Region.t -> token
|
||||
val mk_sym : lexeme -> Region.t -> token
|
||||
val eof : Region.t -> token
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
val is_string : token -> bool
|
||||
val is_bytes : token -> bool
|
||||
val is_int : token -> bool
|
||||
val is_ident : token -> bool
|
||||
val is_kwd : token -> bool
|
||||
val is_constr : token -> bool
|
||||
val is_sym : token -> bool
|
||||
val is_eof : token -> bool
|
||||
|
||||
(* Projections *)
|
||||
|
||||
val to_lexeme : token -> lexeme
|
||||
val to_string : token -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
val to_region : token -> Region.t
|
||||
end
|
||||
|
||||
(* The module type for lexers is [S]. *)
|
||||
|
||||
module type S = sig
|
||||
module Token : TOKEN
|
||||
type token = Token.token
|
||||
|
||||
type file_path = string
|
||||
type logger = Markup.t list -> token -> unit
|
||||
|
||||
val output_token :
|
||||
?offsets:bool -> [`Byte | `Point] ->
|
||||
EvalOpt.command -> out_channel -> logger
|
||||
|
||||
type instance = {
|
||||
read : ?log:logger -> Lexing.lexbuf -> token;
|
||||
buffer : Lexing.lexbuf;
|
||||
get_pos : unit -> Pos.t;
|
||||
get_last : unit -> Region.t;
|
||||
close : unit -> unit
|
||||
}
|
||||
|
||||
val open_token_stream : file_path option -> instance
|
||||
|
||||
(* Error reporting *)
|
||||
|
||||
exception Error of Error.t Region.reg
|
||||
|
||||
val print_error :
|
||||
?offsets:bool -> [`Byte | `Point] -> Error.t Region.reg -> unit
|
||||
|
||||
(* Standalone tracer *)
|
||||
|
||||
val trace :
|
||||
?offsets:bool -> [`Byte | `Point] ->
|
||||
file_path option -> EvalOpt.command -> unit
|
||||
end
|
||||
|
||||
(* The functorised interface
|
||||
|
||||
Note that the module parameter [Token] is re-exported as a
|
||||
submodule in [S].
|
||||
*)
|
||||
|
||||
module Make (Token: TOKEN) : (S with module Token = Token) =
|
||||
struct
|
||||
module Token = Token
|
||||
type token = Token.token
|
||||
|
||||
type file_path = string
|
||||
|
||||
(* THREAD FOR STRUCTURED CONSTRUCTS (STRINGS, COMMENTS) *)
|
||||
|
||||
(* When scanning structured constructs, like strings and comments,
|
||||
we need to keep the region of the opening symbol (like double
|
||||
quote, "//" or "(*") in order to report any error more
|
||||
precisely. Since ocamllex is byte-oriented, we need to store
|
||||
the parsed bytes as characters in an accumulator [acc] and
|
||||
also its length [len], so, we are done, it is easy to build the
|
||||
string making up the structured construct with [mk_str] (see
|
||||
above).
|
||||
|
||||
The resulting data structure is called a _thread_.
|
||||
(Note for Emacs: "*)".)
|
||||
*)
|
||||
|
||||
type thread = {
|
||||
opening : Region.t;
|
||||
len : int;
|
||||
acc : char list
|
||||
}
|
||||
|
||||
let push_char char {opening; len; acc} = {opening; len=len+1; acc=char::acc}
|
||||
|
||||
let push_string str {opening; len; acc} =
|
||||
{opening;
|
||||
len = len + String.length str;
|
||||
acc = explode str acc}
|
||||
|
||||
(* STATE *)
|
||||
|
||||
(* Beyond tokens, the result of lexing is a state (a so-called
|
||||
_state monad_). The type [state] represents the logical state
|
||||
of the lexing engine, that is, a value which is threaded during
|
||||
scanning and which denotes useful, high-level information
|
||||
beyond what the type [Lexing.lexbuf] in the standard library
|
||||
already provides for all generic lexers.
|
||||
|
||||
Tokens are the smallest units used by the parser to build the
|
||||
abstract syntax tree. The state includes a queue of recognised
|
||||
tokens, with the markup at the left of its lexeme until either
|
||||
the start of the file or the end of the previously recognised
|
||||
token.
|
||||
|
||||
The markup from the last recognised token or, if the first
|
||||
token has not been recognised yet, from the beginning of the
|
||||
file is stored in the field [markup] of the state because it is
|
||||
a side-effect, with respect to the output token list, and we
|
||||
use a record with a single field [units] because that record
|
||||
may be easily extended during the future maintenance of this
|
||||
lexer.
|
||||
|
||||
The state also includes a field [pos] which holds the current
|
||||
position in the Ligo source file. The position is not always
|
||||
updated after a single character has been matched: that depends
|
||||
on the regular expression that matched the lexing buffer.
|
||||
|
||||
The fields [decoder] and [supply] offer the support needed
|
||||
for the lexing of UTF-8 encoded characters in comments (the
|
||||
only place where they are allowed in Ligo). The former is the
|
||||
decoder proper and the latter is the effectful function
|
||||
[supply] that takes a byte, a start index and a length and feed
|
||||
it to [decoder]. See the documentation of the third-party
|
||||
library Uutf.
|
||||
*)
|
||||
|
||||
type state = {
|
||||
units : (Markup.t list * token) FQueue.t;
|
||||
markup : Markup.t list;
|
||||
last : Region.t;
|
||||
pos : Pos.t;
|
||||
decoder : Uutf.decoder;
|
||||
supply : Bytes.t -> int -> int -> unit
|
||||
}
|
||||
|
||||
(* The call [enqueue (token, state)] updates functionally the
|
||||
state [state] by associating the token [token] with the stored
|
||||
markup and enqueuing the pair into the units queue. The field
|
||||
[markup] is then reset to the empty list. *)
|
||||
|
||||
let enqueue (token, state) = {
|
||||
state with
|
||||
units = FQueue.enq (state.markup, token) state.units;
|
||||
markup = []
|
||||
}
|
||||
|
||||
(* The call [sync state buffer] updates the current position in
|
||||
accordance with the contents of the lexing buffer, more
|
||||
precisely, depending on the length of the string which has just
|
||||
been recognised by the scanner: that length is used as a
|
||||
positive offset to the current column. *)
|
||||
|
||||
let sync state buffer =
|
||||
let lex = Lexing.lexeme buffer in
|
||||
let len = String.length lex in
|
||||
let start = state.pos in
|
||||
let stop = start#shift_bytes len in
|
||||
let state = {state with pos = stop}
|
||||
in Region.make ~start ~stop, lex, state
|
||||
|
||||
(* MARKUP *)
|
||||
|
||||
(* Committing markup to the current logical state *)
|
||||
|
||||
let push_newline state buffer =
|
||||
let value = Lexing.lexeme buffer
|
||||
and () = Lexing.new_line buffer
|
||||
and start = state.pos in
|
||||
let stop = start#new_line value in
|
||||
let state = {state with pos = stop}
|
||||
and region = Region.make ~start ~stop in
|
||||
let unit = Markup.Newline Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
let push_line (thread, state) =
|
||||
let start = thread.opening#start in
|
||||
let region = Region.make ~start ~stop:state.pos
|
||||
and value = mk_str thread.len thread.acc in
|
||||
let unit = Markup.LineCom Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
let push_block (thread, state) =
|
||||
let start = thread.opening#start in
|
||||
let region = Region.make ~start ~stop:state.pos
|
||||
and value = mk_str thread.len thread.acc in
|
||||
let unit = Markup.BlockCom Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
let push_space state buffer =
|
||||
let region, lex, state = sync state buffer in
|
||||
let value = String.length lex in
|
||||
let unit = Markup.Space Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
let push_tabs state buffer =
|
||||
let region, lex, state = sync state buffer in
|
||||
let value = String.length lex in
|
||||
let unit = Markup.Tabs Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
let push_bom state buffer =
|
||||
let region, value, state = sync state buffer in
|
||||
let unit = Markup.BOM Region.{region; value} in
|
||||
let markup = unit :: state.markup
|
||||
in {state with markup}
|
||||
|
||||
(* ERRORS *)
|
||||
|
||||
type Error.t += Invalid_utf8_sequence
|
||||
type Error.t += Unexpected_character of char
|
||||
type Error.t += Undefined_escape_sequence
|
||||
type Error.t += Missing_break
|
||||
type Error.t += Unterminated_string
|
||||
type Error.t += Unterminated_integer
|
||||
type Error.t += Odd_lengthed_bytes
|
||||
type Error.t += Unterminated_comment
|
||||
type Error.t += Orphan_minus
|
||||
type Error.t += Non_canonical_zero
|
||||
type Error.t += Negative_byte_sequence
|
||||
type Error.t += Broken_string
|
||||
type Error.t += Invalid_character_in_string
|
||||
type Error.t += Reserved_name
|
||||
|
||||
let error_to_string = function
|
||||
Invalid_utf8_sequence ->
|
||||
"Invalid UTF-8 sequence.\n"
|
||||
| Unexpected_character c ->
|
||||
sprintf "Unexpected character '%s'.\n" (Char.escaped c)
|
||||
| Undefined_escape_sequence ->
|
||||
"Undefined escape sequence.\n\
|
||||
Hint: Remove or replace the sequence.\n"
|
||||
| Missing_break ->
|
||||
"Missing break.\n\
|
||||
Hint: Insert some space.\n"
|
||||
| Unterminated_string ->
|
||||
"Unterminated string.\n\
|
||||
Hint: Close with double quotes.\n"
|
||||
| Unterminated_integer ->
|
||||
"Unterminated integer.\n\
|
||||
Hint: Remove the sign or proceed with a natural number.\n"
|
||||
| Odd_lengthed_bytes ->
|
||||
"The length of the byte sequence is an odd number.\n\
|
||||
Hint: Add or remove a digit.\n"
|
||||
| Unterminated_comment ->
|
||||
"Unterminated comment.\n\
|
||||
Hint: Close with \"*)\".\n"
|
||||
| Orphan_minus ->
|
||||
"Orphan minus sign.\n\
|
||||
Hint: Remove the trailing space.\n"
|
||||
| Non_canonical_zero ->
|
||||
"Non-canonical zero.\n\
|
||||
Hint: Use 0.\n"
|
||||
| Negative_byte_sequence ->
|
||||
"Negative byte sequence.\n\
|
||||
Hint: Remove the leading minus sign.\n"
|
||||
| Broken_string ->
|
||||
"The string starting here is interrupted by a line break.\n\
|
||||
Hint: Remove the break or close the string before.\n"
|
||||
| Invalid_character_in_string ->
|
||||
"Invalid character in string.\n\
|
||||
Hint: Remove or replace the character.\n"
|
||||
| Reserved_name ->
|
||||
"Reserved named.\n\
|
||||
Hint: Change the name.\n"
|
||||
| _ -> assert false
|
||||
|
||||
exception Error of Error.t Region.reg
|
||||
|
||||
let fail region value = raise (Error Region.{region; value})
|
||||
|
||||
(* TOKENS *)
|
||||
|
||||
(* Making tokens *)
|
||||
|
||||
let mk_string (thread, state) =
|
||||
let start = thread.opening#start in
|
||||
let stop = state.pos in
|
||||
let region = Region.make ~start ~stop in
|
||||
let lexeme = mk_str thread.len thread.acc in
|
||||
let token = Token.mk_string lexeme region
|
||||
in token, state
|
||||
|
||||
let mk_bytes bytes state buffer =
|
||||
let region, _, state = sync state buffer in
|
||||
let token = Token.mk_bytes bytes region
|
||||
in token, state
|
||||
|
||||
let mk_int state buffer =
|
||||
let region, lexeme, state = sync state buffer in
|
||||
match Token.mk_int lexeme region with
|
||||
Ok token -> token, state
|
||||
| Error Token.Non_canonical_zero ->
|
||||
fail region Non_canonical_zero
|
||||
|
||||
let mk_ident state buffer =
|
||||
let region, lexeme, state = sync state buffer in
|
||||
match Token.mk_ident lexeme region with
|
||||
Ok token -> token, state
|
||||
| Error Token.Reserved_name -> fail region Reserved_name
|
||||
|
||||
let mk_constr state buffer =
|
||||
let region, lexeme, state = sync state buffer
|
||||
in Token.mk_constr lexeme region, state
|
||||
|
||||
let mk_sym state buffer =
|
||||
let region, lexeme, state = sync state buffer
|
||||
in Token.mk_sym lexeme region, state
|
||||
|
||||
let mk_eof state buffer =
|
||||
let region, _, state = sync state buffer
|
||||
in Token.eof region, state
|
||||
|
||||
(* END HEADER *)
|
||||
}
|
||||
|
||||
(* START LEXER DEFINITION *)
|
||||
|
||||
(* Named regular expressions *)
|
||||
|
||||
let utf8_bom = "\xEF\xBB\xBF" (* Byte Order Mark for UTF-8 *)
|
||||
let nl = ['\n' '\r'] | "\r\n"
|
||||
let digit = ['0'-'9']
|
||||
let natural = digit | digit (digit | '_')* digit
|
||||
let integer = '-'? natural
|
||||
let small = ['a'-'z']
|
||||
let capital = ['A'-'Z']
|
||||
let letter = small | capital
|
||||
let ident = small (letter | '_' | digit)*
|
||||
let constr = capital (letter | '_' | digit)*
|
||||
let hexa_digit = digit | ['A'-'F']
|
||||
let byte = hexa_digit hexa_digit
|
||||
let byte_seq = byte | byte (byte | '_')* byte
|
||||
let bytes = "0x" (byte_seq? as seq)
|
||||
let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
|
||||
| "\\r" | "\\t" | "\\x" byte
|
||||
let symbol = ';' | ','
|
||||
| '(' | ')' | '{' | '}' | '[' | ']'
|
||||
| '#' | '|' | "->" | ":=" | '=' | ':'
|
||||
| "||" | "&&" | '<' | "<=" | '>' | ">=" | "=/="
|
||||
| '+' | '-' | '*' | '.' | '_' | '^'
|
||||
|
||||
(* RULES *)
|
||||
|
||||
(* Except for the first rule [init], all rules bear a name starting
|
||||
with "scan".
|
||||
|
||||
All have a parameter [state] that they thread through their
|
||||
recursive calls. The rules for the structured constructs (strings
|
||||
and comments) have an extra parameter of type [thread] (see above).
|
||||
*)
|
||||
|
||||
rule init state = parse
|
||||
utf8_bom { scan (push_bom state lexbuf) lexbuf }
|
||||
| _ { 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 }
|
||||
| integer { mk_int state lexbuf |> enqueue }
|
||||
| symbol { mk_sym state lexbuf |> enqueue }
|
||||
| eof { mk_eof 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 }
|
||||
|
||||
| "(*" { let opening, _, state = sync state lexbuf in
|
||||
let thread = {opening; len=2; acc=['*';'(']} in
|
||||
let state = scan_block thread state lexbuf |> push_block
|
||||
in scan state lexbuf }
|
||||
|
||||
| "//" { let opening, _, state = sync state lexbuf in
|
||||
let thread = {opening; len=2; acc=['/';'/']} in
|
||||
let state = scan_line thread state lexbuf |> push_line
|
||||
in scan state lexbuf }
|
||||
|
||||
(* Some special errors
|
||||
|
||||
Some special errors are recognised in the semantic actions of the
|
||||
following regular expressions. The first error is a minus sign
|
||||
separated from the integer it modifies by some markup (space or
|
||||
tabs). The second is a minus sign immediately followed by
|
||||
anything else than a natural number (matched above) or markup and
|
||||
a number (previous error). The third is the strange occurrence of
|
||||
an attempt at defining a negative byte sequence. Finally, the
|
||||
catch-all rule reports unexpected characters in the buffer (and
|
||||
is not so special, after all).
|
||||
*)
|
||||
|
||||
| '-' { let region, _, state = sync state lexbuf in
|
||||
let state = scan state lexbuf in
|
||||
let open Markup in
|
||||
match FQueue.peek state.units with
|
||||
None -> assert false
|
||||
| Some (_, ((Space _ | Tabs _)::_, token))
|
||||
when Token.is_int token ->
|
||||
fail region Orphan_minus
|
||||
| _ -> fail region Unterminated_integer }
|
||||
|
||||
| '-' "0x" byte_seq?
|
||||
{ let region, _, _ = sync state lexbuf
|
||||
in fail region Negative_byte_sequence }
|
||||
|
||||
| _ as c { let region, _, _ = sync state lexbuf
|
||||
in fail region (Unexpected_character c) }
|
||||
|
||||
(* Finishing a string *)
|
||||
|
||||
and scan_string thread state = parse
|
||||
nl { fail thread.opening Broken_string }
|
||||
| eof { fail thread.opening Unterminated_string }
|
||||
| ['\t' '\r' '\b']
|
||||
{ let region, _, _ = sync state lexbuf
|
||||
in fail region Invalid_character_in_string }
|
||||
| '"' { let _, _, state = sync state lexbuf
|
||||
in push_char '"' thread, state }
|
||||
| esc { let _, lexeme, state = sync state lexbuf
|
||||
in scan_string (push_string lexeme thread) state lexbuf }
|
||||
| '\\' _ { let region, _, _ = sync state lexbuf
|
||||
in fail region Undefined_escape_sequence }
|
||||
| _ as c { let _, _, state = sync state lexbuf in
|
||||
scan_string (push_char c thread) state lexbuf }
|
||||
|
||||
(* Finishing a block comment
|
||||
|
||||
(Note for Emacs: ("(*")
|
||||
The lexing of block comments must take care of embedded block
|
||||
comments that may occur within, as well as strings, so no substring
|
||||
"*)" may inadvertently close the block. This is the purpose
|
||||
of the first case of the scanner [scan_block].
|
||||
*)
|
||||
|
||||
and scan_block thread state = parse
|
||||
'"' | "(*" { let opening = thread.opening in
|
||||
let opening', lexeme, state = sync state lexbuf in
|
||||
let thread = push_string lexeme thread in
|
||||
let thread = {thread with opening=opening'} in
|
||||
let next = if lexeme = "\"" then scan_string
|
||||
else scan_block in
|
||||
let thread, state = next thread state lexbuf in
|
||||
let thread = {thread with opening}
|
||||
in scan_block thread state lexbuf }
|
||||
| "*)" { let _, lexeme, state = sync state lexbuf
|
||||
in push_string lexeme thread, state }
|
||||
| nl as nl { let () = Lexing.new_line lexbuf
|
||||
and state = {state with pos = state.pos#new_line nl}
|
||||
and thread = push_string nl thread
|
||||
in scan_block thread state lexbuf }
|
||||
| eof { fail thread.opening Unterminated_comment }
|
||||
| _ { let () = rollback lexbuf in
|
||||
let len = thread.len in
|
||||
let thread,
|
||||
status = scan_utf8 thread state lexbuf in
|
||||
let delta = thread.len - len in
|
||||
let pos = state.pos#shift_one_uchar delta in
|
||||
match status with
|
||||
None -> scan_block thread {state with pos} lexbuf
|
||||
| Some error ->
|
||||
let region = Region.make ~start:state.pos ~stop:pos
|
||||
in fail region error }
|
||||
|
||||
(* Finishing a line comment *)
|
||||
|
||||
and scan_line thread state = parse
|
||||
nl as nl { let () = Lexing.new_line lexbuf
|
||||
and thread = push_string nl thread
|
||||
and state = {state with pos = state.pos#new_line nl}
|
||||
in thread, state }
|
||||
| eof { fail thread.opening Unterminated_comment }
|
||||
| _ { let () = rollback lexbuf in
|
||||
let len = thread.len in
|
||||
let thread,
|
||||
status = scan_utf8 thread state lexbuf in
|
||||
let delta = thread.len - len in
|
||||
let pos = state.pos#shift_one_uchar delta in
|
||||
match status with
|
||||
None -> scan_line thread {state with pos} lexbuf
|
||||
| Some error ->
|
||||
let region = Region.make ~start:state.pos ~stop:pos
|
||||
in fail region error }
|
||||
|
||||
and scan_utf8 thread state = parse
|
||||
eof { fail thread.opening Unterminated_comment }
|
||||
| _ as c { let thread = push_char c thread in
|
||||
let lexeme = Lexing.lexeme lexbuf in
|
||||
let () = state.supply (Bytes.of_string lexeme) 0 1 in
|
||||
match Uutf.decode state.decoder with
|
||||
`Uchar _ -> thread, None
|
||||
| `Malformed _ -> thread, Some Invalid_utf8_sequence
|
||||
| `Await -> scan_utf8 thread state lexbuf
|
||||
| `End -> assert false }
|
||||
|
||||
(* END LEXER DEFINITION *)
|
||||
|
||||
{
|
||||
(* START TRAILER *)
|
||||
|
||||
(* Scanning the lexing buffer for tokens (and markup, as a
|
||||
side-effect).
|
||||
|
||||
Because we want the lexer to have access to the right lexical
|
||||
context of a recognised lexeme (to enforce stylistic constraints or
|
||||
report special error patterns), we need to keep a hidden reference
|
||||
to a queue of recognised lexical units (that is, tokens and markup)
|
||||
that acts as a mutable state between the calls to
|
||||
[read_token]. When [read_token] is called, that queue is consulted
|
||||
first and, if it contains at least one token, that token is
|
||||
returned; otherwise, the lexing buffer is scanned for at least one
|
||||
more new token. That is the general principle: we put a high-level
|
||||
buffer (our queue) on top of the low-level lexing buffer.
|
||||
|
||||
One tricky and important detail is that we must make any parser
|
||||
generated by Menhir (and calling [read_token]) believe that the
|
||||
last region of the input source that was matched indeed corresponds
|
||||
to the returned token, despite that many tokens and markup may have
|
||||
been matched since it was actually read from the input. In other
|
||||
words, the parser requests a token that is taken from the
|
||||
high-level buffer, but the parser requests the source regions from
|
||||
the _low-level_ lexing buffer, and they may disagree if more than
|
||||
one token has actually been recognised.
|
||||
|
||||
Consequently, in order to maintain a consistent view for the
|
||||
parser, we have to patch some fields of the lexing buffer, namely
|
||||
[lex_start_p] and [lex_curr_p], as these fields are read by parsers
|
||||
generated by Menhir when querying source positions (regions). This
|
||||
is the purpose of the function [patch_buffer]. After reading one
|
||||
ore more tokens and markup by the scanning rule [scan], we have to
|
||||
save in the hidden reference [buf_reg] the region of the source
|
||||
that was matched by [scan]. This atomic sequence of patching,
|
||||
scanning and saving is implemented by the _function_ [scan]
|
||||
(beware: it shadows the scanning rule [scan]). The function
|
||||
[patch_buffer] is, of course, also called just before returning the
|
||||
token, so the parser has a view of the lexing buffer consistent
|
||||
with the token.
|
||||
|
||||
Note that an additional reference [first_call] is needed to
|
||||
distinguish the first call to the function [scan], as the first
|
||||
scanning rule is actually [init] (which can handle the BOM), not
|
||||
[scan].
|
||||
*)
|
||||
|
||||
type logger = Markup.t list -> token -> unit
|
||||
|
||||
type instance = {
|
||||
read : ?log:logger -> Lexing.lexbuf -> token;
|
||||
buffer : Lexing.lexbuf;
|
||||
get_pos : unit -> Pos.t;
|
||||
get_last : unit -> Region.t;
|
||||
close : unit -> unit
|
||||
}
|
||||
|
||||
let file_path = match EvalOpt.input with
|
||||
None | Some "-" -> ""
|
||||
| Some file_path -> file_path
|
||||
let pos = Pos.min#set_file file_path
|
||||
let buf_reg = ref (pos#byte, pos#byte)
|
||||
and first_call = ref true
|
||||
and decoder = Uutf.decoder ~encoding:`UTF_8 `Manual
|
||||
let supply = Uutf.Manual.src decoder
|
||||
let state = ref {units = FQueue.empty;
|
||||
last = Region.ghost;
|
||||
pos;
|
||||
markup = [];
|
||||
decoder;
|
||||
supply}
|
||||
|
||||
let get_pos () = !state.pos
|
||||
|
||||
let get_last () = !state.last
|
||||
|
||||
let patch_buffer (start, stop) buffer =
|
||||
let open Lexing in
|
||||
let file_path = buffer.lex_curr_p.pos_fname in
|
||||
buffer.lex_start_p <- {start with pos_fname = file_path};
|
||||
buffer.lex_curr_p <- {stop with pos_fname = file_path}
|
||||
|
||||
and save_region buffer =
|
||||
buf_reg := Lexing.(buffer.lex_start_p, buffer.lex_curr_p)
|
||||
|
||||
let scan buffer =
|
||||
patch_buffer !buf_reg buffer;
|
||||
(if !first_call
|
||||
then (state := init !state buffer; first_call := false)
|
||||
else state := scan !state buffer);
|
||||
save_region buffer
|
||||
|
||||
let next_token buffer =
|
||||
scan buffer;
|
||||
match FQueue.peek !state.units with
|
||||
None -> assert false
|
||||
| Some (units, ext_token) ->
|
||||
state := {!state with units}; Some ext_token
|
||||
|
||||
let check_right_context token buffer =
|
||||
let open Token in
|
||||
if is_int token || is_bytes token then
|
||||
match next_token buffer with
|
||||
Some ([], next) ->
|
||||
let pos = (Token.to_region token)#stop in
|
||||
let region = Region.make ~start:pos ~stop:pos in
|
||||
if is_bytes token && is_int next then
|
||||
fail region Odd_lengthed_bytes
|
||||
else
|
||||
if is_ident next || is_string next
|
||||
|| is_bytes next || is_int next then
|
||||
fail region Missing_break
|
||||
| _ -> ()
|
||||
else
|
||||
if Token.is_ident token || Token.is_string token then
|
||||
match next_token buffer with
|
||||
Some ([], next) ->
|
||||
if Token.is_ident next || Token.is_string next
|
||||
|| Token.is_bytes next || Token.is_int next
|
||||
then
|
||||
let pos = (Token.to_region token)#stop in
|
||||
let region = Region.make ~start:pos ~stop:pos
|
||||
in fail region Missing_break
|
||||
| _ -> ()
|
||||
|
||||
let rec read_token ?(log=fun _ _ -> ()) buffer =
|
||||
match FQueue.deq !state.units with
|
||||
None ->
|
||||
scan buffer;
|
||||
read_token ~log buffer
|
||||
| Some (units, (left_mark, token)) ->
|
||||
log left_mark token;
|
||||
state := {!state with units; last = Token.to_region token};
|
||||
check_right_context token buffer;
|
||||
patch_buffer (Token.to_region token)#byte_pos buffer;
|
||||
token
|
||||
|
||||
let open_token_stream file_path_opt =
|
||||
let cin = match file_path_opt with
|
||||
None | Some "-" -> stdin
|
||||
| Some file_path -> open_in file_path in
|
||||
let buffer = Lexing.from_channel cin in
|
||||
let () = match file_path_opt with
|
||||
None | Some "-" -> ()
|
||||
| Some file_path -> reset ~file:file_path buffer
|
||||
and close () = close_in cin in
|
||||
{read = read_token; buffer; get_pos; get_last; close}
|
||||
|
||||
(* Standalone lexer for debugging purposes *)
|
||||
|
||||
(* Pretty-printing in a string the lexemes making up the markup
|
||||
between two tokens, concatenated with the last lexeme itself. *)
|
||||
|
||||
let output_token ?(offsets=true) mode command
|
||||
channel left_mark token : unit =
|
||||
let output str = Printf.fprintf channel "%s%!" str in
|
||||
let output_nl str = output (str ^ "\n") in
|
||||
match command with
|
||||
EvalOpt.Quiet -> ()
|
||||
| EvalOpt.Tokens -> Token.to_string token ~offsets mode |> output_nl
|
||||
| EvalOpt.Copy ->
|
||||
let lexeme = Token.to_lexeme token
|
||||
and apply acc markup = Markup.to_lexeme markup :: acc
|
||||
in List.fold_left apply [lexeme] left_mark
|
||||
|> String.concat "" |> output
|
||||
| EvalOpt.Units ->
|
||||
let abs_token = Token.to_string token ~offsets mode
|
||||
and apply acc markup =
|
||||
Markup.to_string markup ~offsets mode :: acc
|
||||
in List.fold_left apply [abs_token] left_mark
|
||||
|> String.concat "\n" |> output_nl
|
||||
|
||||
let print_error ?(offsets=true) mode Region.{region; value} =
|
||||
let msg = error_to_string value in
|
||||
let file = match EvalOpt.input with
|
||||
None | Some "-" -> false
|
||||
| Some _ -> true in
|
||||
let reg = region#to_string ~file ~offsets mode in
|
||||
Utils.highlight (sprintf "Lexical error %s:\n%s%!" reg msg)
|
||||
|
||||
let trace ?(offsets=true) mode file_path_opt command : unit =
|
||||
try
|
||||
let {read; buffer; close; _} = 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
|
||||
let rec iter () =
|
||||
match read ~log buffer with
|
||||
token ->
|
||||
if Token.is_eof token then close_all ()
|
||||
else iter ()
|
||||
| exception Error e -> print_error ~offsets mode e; close_all ()
|
||||
in iter ()
|
||||
with Sys_error msg -> Utils.highlight (sprintf "%s\n" msg)
|
||||
|
||||
end (* of functor [Make] in HEADER *)
|
||||
(* END TRAILER *)
|
||||
}
|
||||
17
src/ligo/parser/LexerMain.ml
Normal file
17
src/ligo/parser/LexerMain.ml
Normal file
@ -0,0 +1,17 @@
|
||||
(* Driver for the lexer of Ligo *)
|
||||
|
||||
open! EvalOpt (* Reads the command-line options: Effectful! *)
|
||||
|
||||
(* Error printing and exception tracing *)
|
||||
|
||||
let () = Printexc.record_backtrace true
|
||||
|
||||
let external_ text =
|
||||
Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;;
|
||||
|
||||
(* Running the lexer on the input file *)
|
||||
|
||||
module Lexer = Lexer.Make (LexToken)
|
||||
|
||||
let () = Lexer.trace ~offsets:EvalOpt.offsets
|
||||
EvalOpt.mode EvalOpt.input EvalOpt.cmd
|
||||
6
src/ligo/parser/MBytes.ml
Normal file
6
src/ligo/parser/MBytes.ml
Normal file
@ -0,0 +1,6 @@
|
||||
(* TEMPORARY: SHOULD BE ERASED *)
|
||||
|
||||
type t = Hex.t
|
||||
|
||||
let of_hex x = x
|
||||
let to_hex x = x
|
||||
6
src/ligo/parser/MBytes.mli
Normal file
6
src/ligo/parser/MBytes.mli
Normal file
@ -0,0 +1,6 @@
|
||||
(* TEMPORARY: SHOULD BE ERASED *)
|
||||
|
||||
type t
|
||||
|
||||
val of_hex : Hex.t -> t
|
||||
val to_hex : t -> Hex.t
|
||||
42
src/ligo/parser/Markup.ml
Normal file
42
src/ligo/parser/Markup.ml
Normal file
@ -0,0 +1,42 @@
|
||||
type lexeme = string
|
||||
|
||||
type t =
|
||||
Tabs of int Region.reg
|
||||
| Space of int Region.reg
|
||||
| Newline of lexeme Region.reg
|
||||
| LineCom of lexeme Region.reg
|
||||
| BlockCom of lexeme Region.reg
|
||||
| BOM of lexeme Region.reg
|
||||
|
||||
type markup = t
|
||||
|
||||
(* Pretty-printing *)
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
let to_lexeme = function
|
||||
Tabs Region.{value;_} -> String.make value '\t'
|
||||
| Space Region.{value;_} -> String.make value ' '
|
||||
| Newline Region.{value;_}
|
||||
| LineCom Region.{value;_}
|
||||
| BlockCom Region.{value;_}
|
||||
| BOM Region.{value;_} -> value
|
||||
|
||||
let to_string markup ?(offsets=true) mode =
|
||||
let region, val_str =
|
||||
match markup with
|
||||
Tabs Region.{value; region} ->
|
||||
let lex = String.make value '\t' |> String.escaped
|
||||
in region, sprintf "Tabs \"%s\"" lex
|
||||
| Space Region.{value; region} ->
|
||||
region, sprintf "Space \"%s\"" (String.make value ' ')
|
||||
| Newline Region.{value; region} ->
|
||||
region, sprintf "Newline \"%s\"" (String.escaped value)
|
||||
| LineCom Region.{value; region} ->
|
||||
region, sprintf "LineCom \"%s\"" (String.escaped value)
|
||||
| BlockCom Region.{value; region} ->
|
||||
region, sprintf "BlockCom \"%s\"" (String.escaped value)
|
||||
| BOM Region.{value; region} ->
|
||||
region, sprintf "BOM \"%s\"" (String.escaped value) in
|
||||
let reg_str = region#compact ~offsets mode
|
||||
in sprintf "%s: %s" reg_str val_str
|
||||
32
src/ligo/parser/Markup.mli
Normal file
32
src/ligo/parser/Markup.mli
Normal file
@ -0,0 +1,32 @@
|
||||
(* This module defines the sorts of markup recognised by the Ligo
|
||||
lexer *)
|
||||
|
||||
(* A lexeme is piece of concrete syntax belonging to a token. In
|
||||
algebraic terms, a token is also a piece of abstract lexical
|
||||
syntax. Lexical units emcompass both markup and lexemes. *)
|
||||
|
||||
type lexeme = string
|
||||
|
||||
type t =
|
||||
Tabs of int Region.reg (* Tabulations *)
|
||||
| Space of int Region.reg (* Space *)
|
||||
| Newline of lexeme Region.reg (* "\n" or "\c\r" escape characters *)
|
||||
| LineCom of lexeme Region.reg (* Line comments *)
|
||||
| BlockCom of lexeme Region.reg (* Block comments *)
|
||||
| BOM of lexeme Region.reg (* Byte-Order Mark for UTF-8 (optional) *)
|
||||
|
||||
type markup = t
|
||||
|
||||
(* Pretty-printing of markup
|
||||
|
||||
The difference between [to_lexeme] and [to_string] is that the
|
||||
former builds the corresponding concrete syntax (the lexeme),
|
||||
whilst the latter makes up a textual representation of the abstract
|
||||
syntax (the OCaml data constructors).
|
||||
|
||||
The result of [to_string] is escaped to avoid capture by the
|
||||
terminal.
|
||||
*)
|
||||
|
||||
val to_lexeme : t -> lexeme
|
||||
val to_string : t -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
88
src/ligo/parser/ParToken.mly
Normal file
88
src/ligo/parser/ParToken.mly
Normal file
@ -0,0 +1,88 @@
|
||||
%{
|
||||
%}
|
||||
|
||||
(* Tokens (mirroring thise defined in module LexToken) *)
|
||||
|
||||
(* Literals *)
|
||||
|
||||
%token <LexToken.lexeme Region.reg> String
|
||||
%token <(LexToken.lexeme * MBytes.t) Region.reg> Bytes
|
||||
%token <(LexToken.lexeme * Z.t) Region.reg> Int
|
||||
%token <LexToken.lexeme Region.reg> Ident
|
||||
%token <LexToken.lexeme Region.reg> Constr
|
||||
|
||||
(* Symbols *)
|
||||
|
||||
%token <Region.t> SEMI (* ";" *)
|
||||
%token <Region.t> COMMA (* "," *)
|
||||
%token <Region.t> LPAR (* "(" *)
|
||||
%token <Region.t> RPAR (* ")" *)
|
||||
%token <Region.t> LBRACE (* "{" *)
|
||||
%token <Region.t> RBRACE (* "}" *)
|
||||
%token <Region.t> LBRACKET (* "[" *)
|
||||
%token <Region.t> RBRACKET (* "]" *)
|
||||
%token <Region.t> CONS (* "#" *)
|
||||
%token <Region.t> VBAR (* "|" *)
|
||||
%token <Region.t> ARROW (* "->" *)
|
||||
%token <Region.t> ASS (* ":=" *)
|
||||
%token <Region.t> EQUAL (* "=" *)
|
||||
%token <Region.t> COLON (* ":" *)
|
||||
%token <Region.t> OR (* "||" *)
|
||||
%token <Region.t> AND (* "&&" *)
|
||||
%token <Region.t> LT (* "<" *)
|
||||
%token <Region.t> LEQ (* "<=" *)
|
||||
%token <Region.t> GT (* ">" *)
|
||||
%token <Region.t> GEQ (* ">=" *)
|
||||
%token <Region.t> NEQ (* "=/=" *)
|
||||
%token <Region.t> PLUS (* "+" *)
|
||||
%token <Region.t> MINUS (* "-" *)
|
||||
%token <Region.t> SLASH (* "/" *)
|
||||
%token <Region.t> TIMES (* "*" *)
|
||||
%token <Region.t> DOT (* "." *)
|
||||
%token <Region.t> WILD (* "_" *)
|
||||
%token <Region.t> CAT (* "^" *)
|
||||
|
||||
(* Keywords *)
|
||||
|
||||
%token <Region.t> Begin (* "begin" *)
|
||||
%token <Region.t> Const (* "const" *)
|
||||
%token <Region.t> Down (* "down" *)
|
||||
%token <Region.t> Fail (* "fail" *)
|
||||
%token <Region.t> If (* "if" *)
|
||||
%token <Region.t> In (* "in" *)
|
||||
%token <Region.t> Is (* "is" *)
|
||||
%token <Region.t> Entrypoint (* "entrypoint" *)
|
||||
%token <Region.t> For (* "for" *)
|
||||
%token <Region.t> Function (* "function" *)
|
||||
%token <Region.t> Storage (* "storage" *)
|
||||
%token <Region.t> Type (* "type" *)
|
||||
%token <Region.t> Of (* "of" *)
|
||||
%token <Region.t> Operations (* "operations" *)
|
||||
%token <Region.t> Var (* "var" *)
|
||||
%token <Region.t> End (* "end" *)
|
||||
%token <Region.t> Then (* "then" *)
|
||||
%token <Region.t> Else (* "else" *)
|
||||
%token <Region.t> Match (* "match" *)
|
||||
%token <Region.t> Null (* "null" *)
|
||||
%token <Region.t> Procedure (* "procedure" *)
|
||||
%token <Region.t> Record (* "record" *)
|
||||
%token <Region.t> Step (* "step" *)
|
||||
%token <Region.t> To (* "to" *)
|
||||
%token <Region.t> Mod (* "mod" *)
|
||||
%token <Region.t> Not (* "not" *)
|
||||
%token <Region.t> While (* "while" *)
|
||||
%token <Region.t> With (* "with" *)
|
||||
|
||||
(* Data constructors *)
|
||||
|
||||
%token <Region.t> C_False (* "False" *)
|
||||
%token <Region.t> C_None (* "None" *)
|
||||
%token <Region.t> C_Some (* "Some" *)
|
||||
%token <Region.t> C_True (* "True" *)
|
||||
%token <Region.t> C_Unit (* "Unit" *)
|
||||
|
||||
(* Virtual tokens *)
|
||||
|
||||
%token <Region.t> EOF
|
||||
|
||||
%%
|
||||
702
src/ligo/parser/Parser.mly
Normal file
702
src/ligo/parser/Parser.mly
Normal file
@ -0,0 +1,702 @@
|
||||
%{
|
||||
(* START HEADER *)
|
||||
|
||||
[@@@warning "-42"]
|
||||
|
||||
open Region
|
||||
open AST
|
||||
|
||||
(* END HEADER *)
|
||||
%}
|
||||
|
||||
(* See [ParToken.mly] for the definition of tokens. *)
|
||||
|
||||
(* Entry points *)
|
||||
|
||||
%start program interactive_expr
|
||||
%type <AST.t> program
|
||||
%type <AST.expr> interactive_expr
|
||||
|
||||
%%
|
||||
|
||||
(* RULES *)
|
||||
|
||||
(* Compound constructs *)
|
||||
|
||||
par(X):
|
||||
LPAR X RPAR {
|
||||
let region = cover $1 $3
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
braces(X):
|
||||
LBRACE X RBRACE {
|
||||
let region = cover $1 $3
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
brackets(X):
|
||||
LBRACKET X RBRACKET {
|
||||
let region = cover $1 $3
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
(* Sequences
|
||||
|
||||
Series of instances of the same syntactical category have often to
|
||||
be parsed, like lists of expressions, patterns etc. The simplest of
|
||||
all is the possibly empty sequence (series), parsed below by
|
||||
[seq]. The non-empty sequence is parsed by [nseq]. Note that the
|
||||
latter returns a pair made of the first parsed item (the parameter
|
||||
[X]) and the rest of the sequence (possibly empty). This way, the
|
||||
OCaml typechecker can keep track of this information along the
|
||||
static control-flow graph. The rule [sepseq] parses possibly empty
|
||||
sequences of items separated by some token (e.g., a comma), and
|
||||
rule [nsepseq] is for non-empty such sequences. See module [Utils]
|
||||
for the types corresponding to the semantic actions of those rules.
|
||||
*)
|
||||
|
||||
(* Possibly empty sequence of items *)
|
||||
|
||||
seq(X):
|
||||
(**) { [] }
|
||||
| X seq(X) { $1::$2 }
|
||||
|
||||
(* Non-empty sequence of items *)
|
||||
|
||||
nseq(X):
|
||||
X seq(X) { $1,$2 }
|
||||
|
||||
(* Non-empty separated sequence of items *)
|
||||
|
||||
nsepseq(X,Sep):
|
||||
X { $1, [] }
|
||||
| X Sep nsepseq(X,Sep) { let h,t = $3 in $1, ($2,h)::t }
|
||||
|
||||
(* Possibly empy separated sequence of items *)
|
||||
|
||||
sepseq(X,Sep):
|
||||
(**) { None }
|
||||
| nsepseq(X,Sep) { Some $1 }
|
||||
|
||||
(* Inlines *)
|
||||
|
||||
%inline var : Ident { $1 }
|
||||
%inline type_name : Ident { $1 }
|
||||
%inline fun_name : Ident { $1 }
|
||||
%inline field_name : Ident { $1 }
|
||||
%inline map_name : Ident { $1 }
|
||||
|
||||
(* Main *)
|
||||
|
||||
program:
|
||||
nseq(declaration) EOF {
|
||||
{decl = $1; eof = $2}
|
||||
}
|
||||
|
||||
declaration:
|
||||
type_decl { TypeDecl $1 }
|
||||
| const_decl { ConstDecl $1 }
|
||||
| storage_decl { StorageDecl $1 }
|
||||
| operations_decl { OpDecl $1 }
|
||||
| lambda_decl { LambdaDecl $1 }
|
||||
|
||||
storage_decl:
|
||||
Storage var COLON type_expr option(SEMI) {
|
||||
let stop =
|
||||
match $5 with
|
||||
None -> type_expr_to_region $4
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_storage = $1;
|
||||
name = $2;
|
||||
colon = $3;
|
||||
store_type = $4;
|
||||
terminator = $5}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
operations_decl:
|
||||
Operations var COLON type_expr option(SEMI) {
|
||||
let stop =
|
||||
match $5 with
|
||||
None -> type_expr_to_region $4
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_operations = $1;
|
||||
name = $2;
|
||||
colon = $3;
|
||||
op_type = $4;
|
||||
terminator = $5}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
(* Type declarations *)
|
||||
|
||||
type_decl:
|
||||
Type type_name Is type_expr option(SEMI) {
|
||||
let stop =
|
||||
match $5 with
|
||||
None -> type_expr_to_region $4
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_type = $1;
|
||||
name = $2;
|
||||
kwd_is = $3;
|
||||
type_expr = $4;
|
||||
terminator = $5}
|
||||
in {region; value}}
|
||||
|
||||
type_expr:
|
||||
cartesian { Prod $1 }
|
||||
| sum_type { Sum $1 }
|
||||
| record_type { Record $1 }
|
||||
|
||||
cartesian:
|
||||
nsepseq(core_type,TIMES) {
|
||||
let region = nsepseq_to_region type_expr_to_region $1
|
||||
in {region; value=$1}
|
||||
}
|
||||
|
||||
core_type:
|
||||
type_name {
|
||||
TAlias $1
|
||||
}
|
||||
| type_name type_tuple {
|
||||
let region = cover $1.region $2.region
|
||||
in TypeApp {region; value = $1,$2}
|
||||
}
|
||||
| par(type_expr) {
|
||||
ParType $1
|
||||
}
|
||||
|
||||
type_tuple:
|
||||
par(nsepseq(type_name,COMMA)) { $1 }
|
||||
|
||||
sum_type:
|
||||
nsepseq(variant,VBAR) {
|
||||
let region = nsepseq_to_region (fun x -> x.region) $1
|
||||
in {region; value=$1}
|
||||
}
|
||||
|
||||
variant:
|
||||
Constr Of cartesian {
|
||||
let region = cover $1.region $3.region
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
record_type:
|
||||
Record
|
||||
nsepseq(field_decl,SEMI)
|
||||
End
|
||||
{
|
||||
let region = cover $1 $3
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
field_decl:
|
||||
field_name COLON type_expr {
|
||||
let stop = type_expr_to_region $3 in
|
||||
let region = cover $1.region stop
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
(* Function and procedure declarations *)
|
||||
|
||||
lambda_decl:
|
||||
fun_decl { FunDecl $1 }
|
||||
| proc_decl { ProcDecl $1 }
|
||||
| entry_decl { EntryDecl $1 }
|
||||
|
||||
fun_decl:
|
||||
Function fun_name parameters COLON type_expr Is
|
||||
seq(local_decl)
|
||||
block
|
||||
With expr option(SEMI) {
|
||||
let stop =
|
||||
match $11 with
|
||||
None -> expr_to_region $10
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_function = $1;
|
||||
name = $2;
|
||||
param = $3;
|
||||
colon = $4;
|
||||
ret_type = $5;
|
||||
kwd_is = $6;
|
||||
local_decls = $7;
|
||||
block = $8;
|
||||
kwd_with = $9;
|
||||
return = $10;
|
||||
terminator = $11}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
proc_decl:
|
||||
Procedure fun_name parameters Is
|
||||
seq(local_decl)
|
||||
block option(SEMI)
|
||||
{
|
||||
let stop =
|
||||
match $7 with
|
||||
None -> $6.region
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_procedure = $1;
|
||||
name = $2;
|
||||
param = $3;
|
||||
kwd_is = $4;
|
||||
local_decls = $5;
|
||||
block = $6;
|
||||
terminator = $7}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
entry_decl:
|
||||
Entrypoint fun_name parameters Is
|
||||
seq(local_decl)
|
||||
block option(SEMI)
|
||||
{
|
||||
let stop =
|
||||
match $7 with
|
||||
None -> $6.region
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_entrypoint = $1;
|
||||
name = $2;
|
||||
param = $3;
|
||||
kwd_is = $4;
|
||||
local_decls = $5;
|
||||
block = $6;
|
||||
terminator = $7}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
parameters:
|
||||
par(nsepseq(param_decl,SEMI)) { $1 }
|
||||
|
||||
param_decl:
|
||||
Var var COLON type_expr {
|
||||
let stop = type_expr_to_region $4 in
|
||||
let region = cover $1 stop
|
||||
in ParamVar {region; value = $1,$2,$3,$4}
|
||||
}
|
||||
| Const var COLON type_expr {
|
||||
let stop = type_expr_to_region $4 in
|
||||
let region = cover $1 stop
|
||||
in ParamConst {region; value = $1,$2,$3,$4}
|
||||
}
|
||||
|
||||
block:
|
||||
Begin
|
||||
instruction after_instr
|
||||
{
|
||||
let instrs, terminator, close = $3 in
|
||||
let region = cover $1 close in
|
||||
let value = {
|
||||
opening = $1;
|
||||
instr = (let value = $2, instrs in
|
||||
let region = nsepseq_to_region instr_to_region value
|
||||
in {value; region});
|
||||
terminator;
|
||||
close}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
after_instr:
|
||||
SEMI instr_or_end {
|
||||
match $2 with
|
||||
`Some (instr, instrs, term, close) ->
|
||||
($1, instr)::instrs, term, close
|
||||
| `End close ->
|
||||
[], Some $1, close
|
||||
}
|
||||
| End {
|
||||
[], None, $1
|
||||
}
|
||||
|
||||
instr_or_end:
|
||||
End {
|
||||
`End $1 }
|
||||
| instruction after_instr {
|
||||
let instrs, term, close = $2 in
|
||||
`Some ($1, instrs, term, close)
|
||||
}
|
||||
|
||||
local_decl:
|
||||
lambda_decl { LocalLam $1 }
|
||||
| const_decl { LocalConst $1 }
|
||||
| var_decl { LocalVar $1 }
|
||||
|
||||
const_decl:
|
||||
Const var COLON type_expr EQUAL expr option(SEMI) {
|
||||
let stop =
|
||||
match $7 with
|
||||
None -> expr_to_region $6
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_const = $1;
|
||||
name = $2;
|
||||
colon = $3;
|
||||
const_type = $4;
|
||||
equal = $5;
|
||||
init = $6;
|
||||
terminator = $7}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
var_decl:
|
||||
Var var COLON type_expr ASS expr option(SEMI) {
|
||||
let stop =
|
||||
match $7 with
|
||||
None -> expr_to_region $6
|
||||
| Some region -> region in
|
||||
let region = cover $1 stop in
|
||||
let value = {
|
||||
kwd_var = $1;
|
||||
name = $2;
|
||||
colon = $3;
|
||||
var_type = $4;
|
||||
ass = $5;
|
||||
init = $6;
|
||||
terminator = $7}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
instruction:
|
||||
single_instr { Single $1 }
|
||||
| block { Block $1 }
|
||||
|
||||
single_instr:
|
||||
conditional { Cond $1 }
|
||||
| match_instr { Match $1 }
|
||||
| ass { Ass $1 }
|
||||
| loop { Loop $1 }
|
||||
| proc_call { ProcCall $1 }
|
||||
| Null { Null $1 }
|
||||
| Fail expr { let region = cover $1 (expr_to_region $2)
|
||||
in Fail {region; value = $1,$2} }
|
||||
|
||||
proc_call:
|
||||
fun_call { $1 }
|
||||
|
||||
conditional:
|
||||
If expr Then instruction Else instruction {
|
||||
let region = cover $1 (instr_to_region $6) in
|
||||
let value = {
|
||||
kwd_if = $1;
|
||||
test = $2;
|
||||
kwd_then = $3;
|
||||
ifso = $4;
|
||||
kwd_else = $5;
|
||||
ifnot = $6}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
match_instr:
|
||||
Match expr With option(VBAR) cases End {
|
||||
let region = cover $1 $6 in
|
||||
let value = {
|
||||
kwd_match = $1;
|
||||
expr = $2;
|
||||
kwd_with = $3;
|
||||
lead_vbar = $4;
|
||||
cases = $5;
|
||||
kwd_end = $6}
|
||||
in {region; value}
|
||||
}
|
||||
|
||||
cases:
|
||||
nsepseq(case,VBAR) {
|
||||
let region = nsepseq_to_region (fun x -> x.region) $1
|
||||
in {region; value=$1}
|
||||
}
|
||||
|
||||
case:
|
||||
pattern ARROW instruction {
|
||||
let region = cover $1.region (instr_to_region $3)
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
ass:
|
||||
var ASS expr {
|
||||
let region = cover $1.region (expr_to_region $3)
|
||||
in {region; value = $1,$2,$3}
|
||||
}
|
||||
|
||||
loop:
|
||||
while_loop { $1 }
|
||||
| for_loop { $1 }
|
||||
|
||||
while_loop:
|
||||
While expr block {
|
||||
let region = cover $1 $3.region
|
||||
in While {region; value=$1,$2,$3}
|
||||
}
|
||||
|
||||
for_loop:
|
||||
For ass Down? To expr option(step_clause) block {
|
||||
let region = cover $1 $7.region in
|
||||
let value =
|
||||
{
|
||||
kwd_for = $1;
|
||||
ass = $2;
|
||||
down = $3;
|
||||
kwd_to = $4;
|
||||
bound = $5;
|
||||
step = $6;
|
||||
block = $7;
|
||||
}
|
||||
in For (ForInt {region; value})
|
||||
}
|
||||
|
||||
| For var option(arrow_clause) In expr block {
|
||||
let region = cover $1 $6.region in
|
||||
let value =
|
||||
{
|
||||
kwd_for = $1;
|
||||
var = $2;
|
||||
bind_to = $3;
|
||||
kwd_in = $4;
|
||||
expr = $5;
|
||||
block = $6;
|
||||
}
|
||||
in For (ForCollect {region; value})
|
||||
}
|
||||
|
||||
step_clause:
|
||||
Step expr { $1,$2 }
|
||||
|
||||
arrow_clause:
|
||||
ARROW var { $1,$2 }
|
||||
|
||||
(* Expressions *)
|
||||
|
||||
interactive_expr:
|
||||
expr EOF { $1 }
|
||||
|
||||
expr:
|
||||
expr OR conj_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Or {region; value = $1,$2,$3}
|
||||
}
|
||||
| conj_expr { $1 }
|
||||
|
||||
conj_expr:
|
||||
conj_expr AND comp_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
And {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr { $1 }
|
||||
|
||||
comp_expr:
|
||||
comp_expr LT cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Lt {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr LEQ cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Leq {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr GT cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Gt {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr GEQ cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Geq {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr EQUAL cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Equal {region; value = $1,$2,$3}
|
||||
}
|
||||
| comp_expr NEQ cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Neq {region; value = $1,$2,$3}
|
||||
}
|
||||
| cat_expr { $1 }
|
||||
|
||||
cat_expr:
|
||||
cons_expr CAT cat_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Cat {region; value = $1,$2,$3}
|
||||
}
|
||||
| cons_expr { $1 }
|
||||
|
||||
cons_expr:
|
||||
add_expr CONS cons_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Cons {region; value = $1,$2,$3}
|
||||
}
|
||||
| add_expr { $1 }
|
||||
|
||||
add_expr:
|
||||
add_expr PLUS mult_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Add {region; value = $1,$2,$3}
|
||||
}
|
||||
| add_expr MINUS mult_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Sub {region; value = $1,$2,$3}
|
||||
}
|
||||
| mult_expr { $1 }
|
||||
|
||||
mult_expr:
|
||||
mult_expr TIMES unary_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Mult {region; value = $1,$2,$3}
|
||||
}
|
||||
| mult_expr SLASH unary_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Div {region; value = $1,$2,$3}
|
||||
}
|
||||
| mult_expr Mod unary_expr {
|
||||
let start = expr_to_region $1
|
||||
and stop = expr_to_region $3 in
|
||||
let region = cover start stop in
|
||||
Mod {region; value = $1,$2,$3}
|
||||
}
|
||||
| unary_expr { $1 }
|
||||
|
||||
unary_expr:
|
||||
MINUS core_expr {
|
||||
let stop = expr_to_region $2 in
|
||||
let region = cover $1 stop in
|
||||
Neg {region; value = $1,$2}
|
||||
}
|
||||
| Not core_expr {
|
||||
let stop = expr_to_region $2 in
|
||||
let region = cover $1 stop in
|
||||
Not {region; value = $1,$2}
|
||||
}
|
||||
| core_expr { $1 }
|
||||
|
||||
core_expr:
|
||||
Int { Int $1 }
|
||||
| var { Var $1 }
|
||||
| String { String $1 }
|
||||
| Bytes { Bytes $1 }
|
||||
| C_False { False $1 }
|
||||
| C_True { True $1 }
|
||||
| C_Unit { Unit $1 }
|
||||
| tuple { Tuple $1 }
|
||||
| list_expr { List $1 }
|
||||
| empty_list { EmptyList $1 }
|
||||
| set_expr { Set $1 }
|
||||
| empty_set { EmptySet $1 }
|
||||
| none_expr { NoneExpr $1 }
|
||||
| fun_call { FunCall $1 }
|
||||
| Constr arguments {
|
||||
let region = cover $1.region $2.region in
|
||||
ConstrApp {region; value = $1,$2}
|
||||
}
|
||||
| C_Some arguments {
|
||||
let region = cover $1 $2.region in
|
||||
SomeApp {region; value = $1,$2}
|
||||
}
|
||||
| map_name DOT brackets(expr) {
|
||||
let region = cover $1.region $3.region in
|
||||
let value =
|
||||
{
|
||||
map_name = $1;
|
||||
selector = $2;
|
||||
index = $3;
|
||||
}
|
||||
in MapLookUp {region; value}
|
||||
}
|
||||
|
||||
fun_call:
|
||||
fun_name arguments {
|
||||
let region = cover $1.region $2.region
|
||||
in {region; value = $1,$2}
|
||||
}
|
||||
|
||||
tuple:
|
||||
par(nsepseq(expr,COMMA)) { $1 }
|
||||
|
||||
arguments:
|
||||
tuple { $1 }
|
||||
|
||||
list_expr:
|
||||
brackets(nsepseq(expr,COMMA)) { $1 }
|
||||
|
||||
empty_list:
|
||||
par(LBRACKET RBRACKET COLON type_expr { $1,$2,$3,$4 }) { $1 }
|
||||
|
||||
set_expr:
|
||||
braces(nsepseq(expr,COMMA)) { $1 }
|
||||
|
||||
empty_set:
|
||||
par(LBRACE RBRACE COLON type_expr { $1,$2,$3,$4 }) { $1 }
|
||||
|
||||
none_expr:
|
||||
par(C_None COLON type_expr { $1,$2,$3 }) { $1 }
|
||||
|
||||
(* Patterns *)
|
||||
|
||||
pattern:
|
||||
nsepseq(core_pattern,CONS) {
|
||||
let region = nsepseq_to_region core_pattern_to_region $1
|
||||
in {region; value=$1}
|
||||
}
|
||||
|
||||
core_pattern:
|
||||
var { PVar $1 }
|
||||
| WILD { PWild $1 }
|
||||
| Int { PInt $1 }
|
||||
| String { PString $1 }
|
||||
| C_Unit { PUnit $1 }
|
||||
| C_False { PFalse $1 }
|
||||
| C_True { PTrue $1 }
|
||||
| C_None { PNone $1 }
|
||||
| list_patt { PList $1 }
|
||||
| tuple_patt { PTuple $1 }
|
||||
| C_Some par(core_pattern) {
|
||||
let region = cover $1 $2.region
|
||||
in PSome {region; value = $1,$2}
|
||||
}
|
||||
|
||||
list_patt:
|
||||
brackets(sepseq(core_pattern,COMMA)) { Sugar $1 }
|
||||
| par(cons_pattern) { Raw $1 }
|
||||
|
||||
cons_pattern:
|
||||
core_pattern CONS pattern { $1,$2,$3 }
|
||||
|
||||
tuple_patt:
|
||||
par(nsepseq(core_pattern,COMMA)) { $1 }
|
||||
83
src/ligo/parser/ParserMain.ml
Normal file
83
src/ligo/parser/ParserMain.ml
Normal file
@ -0,0 +1,83 @@
|
||||
(* Driver for the parser of Ligo *)
|
||||
|
||||
open! EvalOpt (* Reads the command-line options: Effectful! *)
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
(* Error printing and exception tracing *)
|
||||
|
||||
let () = Printexc.record_backtrace true
|
||||
|
||||
let external_ text =
|
||||
Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;;
|
||||
|
||||
type Error.t += ParseError
|
||||
|
||||
let error_to_string = function
|
||||
ParseError -> "Syntax error.\n"
|
||||
| _ -> assert false
|
||||
|
||||
let print_error ?(offsets=true) mode Region.{region; value} =
|
||||
let msg = error_to_string value in
|
||||
let file = match EvalOpt.input with
|
||||
None | Some "-" -> false
|
||||
| Some _ -> true in
|
||||
let reg = region#to_string ~file ~offsets mode in
|
||||
Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg)
|
||||
|
||||
(* Path to the Ligo standard library *)
|
||||
(*
|
||||
let lib_path =
|
||||
match EvalOpt.libs with
|
||||
[] -> ""
|
||||
| libs -> let mk_I dir path = Printf.sprintf " -I %s%s" dir path
|
||||
in List.fold_right mk_I libs ""
|
||||
*)
|
||||
|
||||
(* Instanciating the lexer *)
|
||||
|
||||
module Lexer = Lexer.Make (LexToken)
|
||||
|
||||
let Lexer.{read; buffer; get_pos; get_last; close} =
|
||||
Lexer.open_token_stream EvalOpt.input
|
||||
|
||||
and cout = stdout
|
||||
|
||||
let log = Lexer.output_token ~offsets:EvalOpt.offsets
|
||||
EvalOpt.mode EvalOpt.cmd cout
|
||||
|
||||
and close_all () = close (); close_out cout
|
||||
|
||||
(* Tokeniser *)
|
||||
|
||||
let tokeniser = read ~log
|
||||
|
||||
(* Main *)
|
||||
|
||||
let () =
|
||||
try
|
||||
let ast = Parser.program tokeniser buffer in
|
||||
if Utils.String.Set.mem "ast" EvalOpt.verbose
|
||||
then AST.print_tokens ast
|
||||
with
|
||||
Lexer.Error err ->
|
||||
close_all ();
|
||||
Lexer.print_error ~offsets EvalOpt.mode err
|
||||
| Parser.Error ->
|
||||
let region = get_last () in
|
||||
let error = Region.{region; value=ParseError} in
|
||||
let () = close_all () in
|
||||
print_error ~offsets EvalOpt.mode error
|
||||
| Sys_error msg -> Utils.highlight msg
|
||||
|
||||
(* Temporary: force dune to build AST2.ml *)
|
||||
let () =
|
||||
let open AST2 in
|
||||
let _ = s_ast in
|
||||
()
|
||||
|
||||
(* Temporary: force dune to build AST2.ml *)
|
||||
let () =
|
||||
let open Typecheck2 in
|
||||
let _ = temporary_force_dune in
|
||||
()
|
||||
124
src/ligo/parser/Pos.ml
Normal file
124
src/ligo/parser/Pos.ml
Normal file
@ -0,0 +1,124 @@
|
||||
type t = <
|
||||
byte : Lexing.position;
|
||||
point_num : int;
|
||||
point_bol : int;
|
||||
file : string;
|
||||
line : int;
|
||||
|
||||
set_file : string -> t;
|
||||
set_line : int -> t;
|
||||
new_line : string -> t;
|
||||
add_nl : t;
|
||||
|
||||
shift_bytes : int -> t;
|
||||
shift_one_uchar : int -> t;
|
||||
|
||||
offset : [`Byte | `Point] -> int;
|
||||
column : [`Byte | `Point] -> int;
|
||||
|
||||
line_offset : [`Byte | `Point] -> int;
|
||||
byte_offset : int;
|
||||
|
||||
is_ghost : bool;
|
||||
|
||||
to_string : ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
compact : ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
anonymous : ?offsets:bool -> [`Byte | `Point] -> string
|
||||
>
|
||||
|
||||
type pos = t
|
||||
|
||||
(* Constructors *)
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
let make ~byte ~point_num ~point_bol =
|
||||
let () = assert (point_num >= point_bol) in
|
||||
object (self)
|
||||
val byte = byte
|
||||
method byte = byte
|
||||
|
||||
val point_num = point_num
|
||||
method point_num = point_num
|
||||
|
||||
val point_bol = point_bol
|
||||
method point_bol = point_bol
|
||||
|
||||
method set_file file = {< byte = Lexing.{byte with pos_fname = file} >}
|
||||
method set_line line = {< byte = Lexing.{byte with pos_lnum = line} >}
|
||||
|
||||
(* 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 >}
|
||||
|
||||
method shift_one_uchar len =
|
||||
{< byte = Lexing.{byte with pos_cnum = byte.pos_cnum + len};
|
||||
point_num = point_num + 1 >}
|
||||
|
||||
method add_nl =
|
||||
{< byte = Lexing.{byte with
|
||||
pos_lnum = byte.pos_lnum + 1;
|
||||
pos_bol = byte.pos_cnum};
|
||||
point_bol = point_num >}
|
||||
|
||||
method new_line string =
|
||||
let len = String.length string
|
||||
in (self#shift_bytes len)#add_nl
|
||||
|
||||
method is_ghost = byte = Lexing.dummy_pos
|
||||
|
||||
method file = byte.Lexing.pos_fname
|
||||
|
||||
method line = byte.Lexing.pos_lnum
|
||||
|
||||
method offset = function
|
||||
`Byte -> Lexing.(byte.pos_cnum - byte.pos_bol)
|
||||
| `Point -> point_num - point_bol
|
||||
|
||||
method column mode = 1 + self#offset mode
|
||||
|
||||
method line_offset = function
|
||||
`Byte -> byte.Lexing.pos_bol
|
||||
| `Point -> 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 =
|
||||
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)
|
||||
|
||||
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)
|
||||
end
|
||||
|
||||
let ghost = make ~byte:Lexing.dummy_pos ~point_num:(-1) ~point_bol:(-1)
|
||||
|
||||
let min =
|
||||
let byte = Lexing.{
|
||||
pos_fname = "";
|
||||
pos_lnum = 1;
|
||||
pos_bol = 0;
|
||||
pos_cnum = 0}
|
||||
in make ~byte ~point_num:0 ~point_bol:0
|
||||
|
||||
(* Comparisons *)
|
||||
|
||||
let equal pos1 pos2 =
|
||||
pos1#file = pos2#file && pos1#byte_offset = pos2#byte_offset
|
||||
|
||||
let lt pos1 pos2 =
|
||||
pos1#file = pos2#file && pos1#byte_offset < pos2#byte_offset
|
||||
105
src/ligo/parser/Pos.mli
Normal file
105
src/ligo/parser/Pos.mli
Normal file
@ -0,0 +1,105 @@
|
||||
(* Positions in a file
|
||||
|
||||
A position in a file denotes a single unit belonging to it, for
|
||||
example, in an ASCII text file, it is a particular character within
|
||||
that file (the unit is the byte in this instance, since in ASCII
|
||||
one character is encoded with one byte).
|
||||
|
||||
Units can be either bytes (as ASCII characters) or, more
|
||||
generally, unicode points.
|
||||
|
||||
The type for positions is the object type [t].
|
||||
|
||||
We use here lexing positions to denote byte-oriented positions
|
||||
(field [byte]), and we manage code points by means of the fields
|
||||
[point_num] and [point_bol]. These two fields have a meaning
|
||||
similar to the fields [pos_cnum] and [pos_bol], respectively, from
|
||||
the standard module [Lexing]. That is to say, [point_num] holds the
|
||||
number of code points since the beginning of the file, and
|
||||
[point_bol] the number of code points since the beginning of the
|
||||
current line.
|
||||
|
||||
The name of the file is given by the field [file], and the line
|
||||
number by the field [line].
|
||||
*)
|
||||
|
||||
type t = <
|
||||
(* Payload *)
|
||||
|
||||
byte : Lexing.position;
|
||||
point_num : int;
|
||||
point_bol : int;
|
||||
file : string;
|
||||
line : int;
|
||||
|
||||
(* Setters *)
|
||||
|
||||
set_file : string -> t;
|
||||
set_line : int -> t;
|
||||
|
||||
(* The call [pos#new_line s], where the string [s] is either "\n" or
|
||||
"\c\r", updates the position [pos] with a new line. *)
|
||||
|
||||
new_line : string -> t;
|
||||
add_nl : t;
|
||||
|
||||
(* The call [pos#shift_bytes n] evaluates in a position that is the
|
||||
translation of position [pos] of [n] bytes forward in the
|
||||
file. The call [pos#shift_one_uchar n] is similar, except that it
|
||||
assumes that [n] is the number of bytes making up one unicode
|
||||
point. *)
|
||||
|
||||
shift_bytes : int -> t;
|
||||
shift_one_uchar : int -> t;
|
||||
|
||||
(* Getters *)
|
||||
|
||||
(* The call [pos#offset `Byte] provides the horizontal offset of the
|
||||
position [pos] in bytes. (An offset is the number of units, like
|
||||
bytes, since the beginning of the current line.) The call
|
||||
[pos#offset `Point] is the offset counted in number of unicode
|
||||
points.
|
||||
|
||||
The calls to the method [column] are similar to those to
|
||||
[offset], except that they give the curren column number.
|
||||
|
||||
The call [pos#line_offset `Byte] is the offset of the line of
|
||||
position [pos], counted in bytes. Dually, [pos#line_offset
|
||||
`Point] counts the same offset in code points.
|
||||
|
||||
The call [pos#byte_offset] is the offset of the position [pos]
|
||||
since the begininng of the file, counted in bytes.
|
||||
*)
|
||||
|
||||
offset : [`Byte | `Point] -> int;
|
||||
column : [`Byte | `Point] -> int;
|
||||
|
||||
line_offset : [`Byte | `Point] -> int;
|
||||
byte_offset : int;
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
is_ghost : bool;
|
||||
|
||||
(* Conversions to [string] *)
|
||||
|
||||
to_string : ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
compact : ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
anonymous : ?offsets:bool -> [`Byte | `Point] -> string
|
||||
>
|
||||
|
||||
type pos = t
|
||||
|
||||
(* Constructors *)
|
||||
|
||||
val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t
|
||||
|
||||
(* Special positions *)
|
||||
|
||||
val ghost : t (* Same as [Lexing.dummy_pos] *)
|
||||
val min : t (* Lexing convention: line 1, offsets to 0 and file to "". *)
|
||||
|
||||
(* Comparisons *)
|
||||
|
||||
val equal : t -> t -> bool
|
||||
val lt : t -> t -> bool
|
||||
122
src/ligo/parser/Region.ml
Normal file
122
src/ligo/parser/Region.ml
Normal file
@ -0,0 +1,122 @@
|
||||
(* Regions of a file *)
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
type t = <
|
||||
start : Pos.t;
|
||||
stop : Pos.t;
|
||||
|
||||
(* Setters *)
|
||||
|
||||
shift_bytes : int -> t;
|
||||
shift_one_uchar : int -> t;
|
||||
|
||||
(* Getters *)
|
||||
|
||||
file : string;
|
||||
pos : Pos.t * Pos.t;
|
||||
byte_pos : Lexing.position * Lexing.position;
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
is_ghost : bool;
|
||||
|
||||
(* Conversions to [string] *)
|
||||
|
||||
to_string : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
>
|
||||
|
||||
type region = t
|
||||
|
||||
type 'a reg = {region: t; value: 'a}
|
||||
|
||||
(* Injections *)
|
||||
|
||||
exception Invalid
|
||||
|
||||
let make ~(start: Pos.t) ~(stop: Pos.t) =
|
||||
if start#file <> stop#file || start#byte_offset > stop#byte_offset
|
||||
then raise Invalid
|
||||
else
|
||||
object
|
||||
val start = start
|
||||
method start = start
|
||||
val stop = stop
|
||||
method stop = stop
|
||||
|
||||
method shift_bytes len =
|
||||
let start = start#shift_bytes len
|
||||
and stop = stop#shift_bytes len
|
||||
in {< start = start; stop = stop >}
|
||||
|
||||
method shift_one_uchar len =
|
||||
let start = start#shift_one_uchar len
|
||||
and stop = stop#shift_one_uchar len
|
||||
in {< start = start; stop = stop >}
|
||||
|
||||
(* Getters *)
|
||||
|
||||
method file = start#file
|
||||
method pos = start, stop
|
||||
method byte_pos = start#byte, stop#byte
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
method is_ghost = start#is_ghost && stop#is_ghost
|
||||
|
||||
(* Conversions to strings *)
|
||||
|
||||
method to_string ?(file=true) ?(offsets=true) mode =
|
||||
let horizontal = if offsets then "character" else "column"
|
||||
and start_offset =
|
||||
if offsets then start#offset mode else start#column mode
|
||||
and stop_offset =
|
||||
if offsets then stop#offset mode else stop#column mode in
|
||||
let info =
|
||||
if file
|
||||
then sprintf "in file \"%s\", line %i, %s"
|
||||
(String.escaped start#file) start#line horizontal
|
||||
else sprintf "at line %i, %s" start#line horizontal
|
||||
in if stop#line = start#line
|
||||
then sprintf "%ss %i-%i" info start_offset stop_offset
|
||||
else sprintf "%s %i to line %i, %s %i"
|
||||
info start_offset stop#line horizontal stop_offset
|
||||
|
||||
method compact ?(file=true) ?(offsets=true) mode =
|
||||
let start_str = start#anonymous ~offsets mode
|
||||
and stop_str = stop#anonymous ~offsets mode in
|
||||
if start#file = stop#file then
|
||||
if file then sprintf "%s:%s-%s" start#file start_str stop_str
|
||||
else sprintf "%s-%s" start_str stop_str
|
||||
else sprintf "%s:%s-%s:%s" start#file start_str stop#file stop_str
|
||||
end
|
||||
|
||||
(* Special regions *)
|
||||
|
||||
let ghost = make ~start:Pos.ghost ~stop:Pos.ghost
|
||||
|
||||
let min = make ~start:Pos.min ~stop:Pos.min
|
||||
|
||||
(* Comparisons *)
|
||||
|
||||
let equal r1 r2 =
|
||||
r1#file = r2#file
|
||||
&& Pos.equal r1#start r2#start
|
||||
&& Pos.equal r1#stop r2#stop
|
||||
|
||||
let lt r1 r2 =
|
||||
r1#file = r2#file
|
||||
&& not r1#is_ghost
|
||||
&& not r2#is_ghost
|
||||
&& Pos.lt r1#start r2#start
|
||||
&& Pos.lt r1#stop r2#stop
|
||||
|
||||
let cover r1 r2 =
|
||||
if r1#is_ghost
|
||||
then r2
|
||||
else if r2#is_ghost
|
||||
then r1
|
||||
else if lt r1 r2
|
||||
then make ~start:r1#start ~stop:r2#stop
|
||||
else make ~start:r2#start ~stop:r1#stop
|
||||
123
src/ligo/parser/Region.mli
Normal file
123
src/ligo/parser/Region.mli
Normal file
@ -0,0 +1,123 @@
|
||||
(* Regions of a file
|
||||
|
||||
A _region_ is a contiguous series of bytes, for example, in a text
|
||||
file. It is here denoted by the object type [t].
|
||||
|
||||
The start (included) of the region is given by the field [start],
|
||||
which is a _position_, and the end (excluded) is the position given
|
||||
by the field [stop]. The convention of including the start and
|
||||
excluding the end enables to have empty regions if, and only if,
|
||||
[start = stop]. See module [Pos] for the definition of positions.
|
||||
|
||||
The first byte of a file starts at the offset zero (that is,
|
||||
column one), and [start] is always lower than or equal to [stop],
|
||||
and they must refer to the same file.
|
||||
*)
|
||||
|
||||
type t = <
|
||||
start : Pos.t;
|
||||
stop : Pos.t;
|
||||
|
||||
(* Setters *)
|
||||
|
||||
(* The call [region#shift_bytes n] evaluates in a region that is the
|
||||
translation of region [region] of [n] bytes forward in the
|
||||
file. The call [region#shift_one_uchar n] is similar, except that
|
||||
it assumes that [n] is the number of bytes making up one unicode
|
||||
point. *)
|
||||
|
||||
shift_bytes : int -> t;
|
||||
shift_one_uchar : int -> t;
|
||||
|
||||
(* Getters *)
|
||||
|
||||
(* The method [file] returns the file name.
|
||||
The method [pos] returns the values of the fields [start] and [stop].
|
||||
The method [byte_pos] returns the start and end positions of the
|
||||
region at hand _interpreting them as lexing positions_, that is,
|
||||
the unit is the byte. *)
|
||||
|
||||
file : string;
|
||||
pos : Pos.t * Pos.t;
|
||||
byte_pos : Lexing.position * Lexing.position;
|
||||
|
||||
(* Predicates *)
|
||||
|
||||
is_ghost : bool;
|
||||
|
||||
(* Conversions to [string] *)
|
||||
|
||||
(* The call [region#to_string ~file ~offsets mode] evaluates in a
|
||||
string denoting the region [region].
|
||||
|
||||
The name of the file is present if, and only if, [file = true] or
|
||||
[file] is missing.
|
||||
|
||||
The positions in the file are expressed horizontal offsets if
|
||||
[offsets = true] or [offsets] is missing (the default), otherwise
|
||||
as columns.
|
||||
|
||||
If [mode = `Byte], those positions will be assumed to have bytes
|
||||
as their unit, otherwise, if [mode = `Point], they will be
|
||||
assumed to refer to code points.
|
||||
|
||||
The method [compact] has the same signature and calling
|
||||
convention as [to_string], except that the resulting string is
|
||||
more compact.
|
||||
*)
|
||||
|
||||
to_string : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
|
||||
compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string
|
||||
>
|
||||
|
||||
type region = t
|
||||
|
||||
type 'a reg = {region: t; value: 'a}
|
||||
|
||||
(* Constructors *)
|
||||
|
||||
(* The function [make] creates a region from two positions. If the
|
||||
positions are not properly ordered or refer to different files, the
|
||||
exception [Invalid] is raised. *)
|
||||
|
||||
exception Invalid
|
||||
|
||||
val make : start:Pos.t -> stop:Pos.t -> t
|
||||
|
||||
(* Special regions *)
|
||||
|
||||
(* To deal with ghost expressions, that is, pieces of abstract syntax
|
||||
that have not been built from excerpts of concrete syntax, we need
|
||||
_ghost regions_. The module [Pos] provides a [ghost] position, and
|
||||
we also provide a [ghost] region and, in type [t], the method
|
||||
[is_ghost] to check it. *)
|
||||
|
||||
val ghost : t (* Two [Pos.ghost] positions *)
|
||||
|
||||
(* Occasionnally, we may need a minimum region. It is here made of two
|
||||
minimal positions. *)
|
||||
|
||||
val min : t (* Two [Pos.min] positions *)
|
||||
|
||||
(* Comparisons *)
|
||||
|
||||
(* Two regions are equal if, and only if, they refer to the same file
|
||||
and their start positions are equal and their stop positions are
|
||||
equal. See [Pos.equal]. Note that [r1] and [r2] can be ghosts. *)
|
||||
|
||||
val equal : t -> t -> bool
|
||||
|
||||
(* The call [lt r1 r2] ("lower than") has the value [true] if, and
|
||||
only if, regions [r1] and [r2] refer to the same file, none is a
|
||||
ghost and the start position of [r1] is lower than that of
|
||||
[r2]. (See [Pos.lt].) *)
|
||||
|
||||
val lt : t -> t -> bool
|
||||
|
||||
(* Given two regions [r1] and [r2], we may want the region [cover r1
|
||||
r2] that covers [r1] and [r2]. We property [equal (cover r1 r2)
|
||||
(cover r2 r1)]. (In a sense, it is the maximum region, but we avoid
|
||||
that name because of the [min] function above.) If [r1] is a ghost,
|
||||
the cover is [r2], and if [r2] is a ghost, the cover is [r1]. *)
|
||||
|
||||
val cover : t -> t -> t
|
||||
29
src/ligo/parser/Tests/a.li
Normal file
29
src/ligo/parser/Tests/a.li
Normal file
@ -0,0 +1,29 @@
|
||||
type t is int * string
|
||||
type u is t
|
||||
type v is record foo: key; bar: mutez; baz: address end
|
||||
type w is K of (U of int) (*v * u*)
|
||||
|
||||
storage s : w // Line comment
|
||||
operations o : u;
|
||||
|
||||
type i is int;
|
||||
|
||||
(* Block comment *)
|
||||
|
||||
entrypoint g (const l : list (int)) is
|
||||
function f (const x : int) : int is
|
||||
var y : int := 5 - x
|
||||
const z : int = 6
|
||||
begin
|
||||
y := x + y
|
||||
end with y * 2
|
||||
begin
|
||||
match l with
|
||||
[] -> null
|
||||
| h#t -> q (h+2)
|
||||
end;
|
||||
begin
|
||||
g (Unit);
|
||||
fail "in extremis"
|
||||
end
|
||||
end
|
||||
107
src/ligo/parser/Typecheck2.ml
Normal file
107
src/ligo/parser/Typecheck2.ml
Normal file
@ -0,0 +1,107 @@
|
||||
[@@@warning "-30"]
|
||||
|
||||
module SMap = Map.Make(String)
|
||||
|
||||
module O = struct
|
||||
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
|
||||
|
||||
type type_name = string
|
||||
type var_name = { name: string; orig: asttodo }
|
||||
type record_key = [`Field of string | `Component of int]
|
||||
|
||||
type pattern =
|
||||
PVar of var_name
|
||||
| PWild
|
||||
| PInt of Z.t
|
||||
| PBytes of MBytes.t
|
||||
| PString of string
|
||||
| PUnit
|
||||
| PFalse
|
||||
| PTrue
|
||||
| PNone
|
||||
| PSome of pattern
|
||||
| PCons of pattern * pattern
|
||||
| PNull
|
||||
| PRecord of pattern list
|
||||
|
||||
type type_constructor =
|
||||
| Option
|
||||
| List
|
||||
| Set
|
||||
| Map
|
||||
|
||||
type type_expr_case =
|
||||
| Sum of (type_name * type_expr_case) list
|
||||
| Record of record_key type_record
|
||||
| TypeApp of type_constructor * (type_expr_case list)
|
||||
| Function of { args: type_expr_case list; ret: type_expr_case }
|
||||
| Ref of type_expr_case
|
||||
| TC of type_constructor
|
||||
| String
|
||||
| Int
|
||||
| Unit
|
||||
| Bool
|
||||
and 'key type_record = ('key * type_expr_case) list
|
||||
|
||||
type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr }
|
||||
|
||||
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
|
||||
|
||||
type type_decl = { name:string; ty:type_expr; orig: asttodo }
|
||||
|
||||
type expr_case =
|
||||
App of { operator: operator; arguments: expr list }
|
||||
| Var of typed_var
|
||||
| Constant of constant
|
||||
| Record of record_key expr_record
|
||||
| Lambda of lambda
|
||||
|
||||
and 'key expr_record = ('key * expr list)
|
||||
|
||||
and expr = { expr: expr_case; ty:type_expr; orig: asttodo }
|
||||
|
||||
and decl = { var: typed_var; value: expr; orig: asttodo }
|
||||
|
||||
and lambda = {
|
||||
parameters: typed_var SMap.t;
|
||||
declarations: decl list;
|
||||
instructions: instr list;
|
||||
result: expr;
|
||||
}
|
||||
|
||||
and operator_case =
|
||||
Function of string
|
||||
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
|
||||
| Neg | Not
|
||||
| Set
|
||||
| MapLookup
|
||||
|
||||
and operator = { operator: operator_case; ty:type_expr; orig: asttodo }
|
||||
|
||||
and constant =
|
||||
Unit
|
||||
| Int of Z.t | String of string | Bytes of MBytes.t
|
||||
| False | True
|
||||
| Null
|
||||
| EmptySet
|
||||
| CNone
|
||||
|
||||
and instr =
|
||||
Assignment of { name: var_name; value: expr; orig: asttodo }
|
||||
| While of { condition: expr; body: instr list; orig: asttodo }
|
||||
| ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo }
|
||||
| If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo }
|
||||
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
|
||||
| DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
|
||||
| Fail of { expr: expr; orig: asttodo }
|
||||
|
||||
type ast = {
|
||||
types : type_decl list;
|
||||
storage_decl : typed_var;
|
||||
operations_decl : typed_var;
|
||||
declarations : decl list;
|
||||
orig: AST.t
|
||||
}
|
||||
end
|
||||
|
||||
let temporary_force_dune = 123
|
||||
107
src/ligo/parser/Typecheck2.mli
Normal file
107
src/ligo/parser/Typecheck2.mli
Normal file
@ -0,0 +1,107 @@
|
||||
[@@@warning "-30"]
|
||||
|
||||
module SMap : Map.S with type key = string
|
||||
|
||||
module O : sig
|
||||
type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *)
|
||||
|
||||
type type_name = string
|
||||
type var_name = { name: string; orig: asttodo }
|
||||
type record_key = [`Field of string | `Component of int]
|
||||
|
||||
type pattern =
|
||||
PVar of var_name
|
||||
| PWild
|
||||
| PInt of Z.t
|
||||
| PBytes of MBytes.t
|
||||
| PString of string
|
||||
| PUnit
|
||||
| PFalse
|
||||
| PTrue
|
||||
| PNone
|
||||
| PSome of pattern
|
||||
| PCons of pattern * pattern
|
||||
| PNull
|
||||
| PRecord of pattern list
|
||||
|
||||
type type_constructor =
|
||||
| Option
|
||||
| List
|
||||
| Set
|
||||
| Map
|
||||
|
||||
type type_expr_case =
|
||||
| Sum of (type_name * type_expr_case) list
|
||||
| Record of record_key type_record
|
||||
| TypeApp of type_constructor * (type_expr_case list)
|
||||
| Function of { args: type_expr_case list; ret: type_expr_case }
|
||||
| Ref of type_expr_case
|
||||
| TC of type_constructor
|
||||
| String
|
||||
| Int
|
||||
| Unit
|
||||
| Bool
|
||||
and 'key type_record = ('key * type_expr_case) list
|
||||
|
||||
type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr }
|
||||
|
||||
type typed_var = { name:var_name; ty:type_expr; orig: asttodo }
|
||||
|
||||
type type_decl = { name:string; ty:type_expr; orig: asttodo }
|
||||
|
||||
type expr_case =
|
||||
App of { operator: operator; arguments: expr list }
|
||||
| Var of typed_var
|
||||
| Constant of constant
|
||||
| Record of record_key expr_record
|
||||
| Lambda of lambda
|
||||
|
||||
and 'key expr_record = ('key * expr list)
|
||||
|
||||
and expr = { expr: expr_case; ty:type_expr; orig: asttodo }
|
||||
|
||||
and decl = { var: typed_var; value: expr; orig: asttodo }
|
||||
|
||||
and lambda = {
|
||||
parameters: typed_var SMap.t;
|
||||
declarations: decl list;
|
||||
instructions: instr list;
|
||||
result: expr;
|
||||
}
|
||||
|
||||
and operator_case =
|
||||
Function of string
|
||||
| Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod
|
||||
| Neg | Not
|
||||
| Set
|
||||
| MapLookup
|
||||
|
||||
and operator = { operator: operator_case; ty:type_expr; orig: asttodo }
|
||||
|
||||
and constant =
|
||||
Unit
|
||||
| Int of Z.t | String of string | Bytes of MBytes.t
|
||||
| False | True
|
||||
| Null
|
||||
| EmptySet
|
||||
| CNone
|
||||
|
||||
and instr =
|
||||
Assignment of { name: var_name; value: expr; orig: asttodo }
|
||||
| While of { condition: expr; body: instr list; orig: asttodo }
|
||||
| ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo }
|
||||
| If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo }
|
||||
| Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo }
|
||||
| DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *)
|
||||
| Fail of { expr: expr; orig: asttodo }
|
||||
|
||||
type ast = {
|
||||
types : type_decl list;
|
||||
storage_decl : typed_var;
|
||||
operations_decl : typed_var;
|
||||
declarations : decl list;
|
||||
orig: AST.t
|
||||
}
|
||||
end
|
||||
|
||||
val temporary_force_dune : int
|
||||
157
src/ligo/parser/Utils.ml
Normal file
157
src/ligo/parser/Utils.ml
Normal file
@ -0,0 +1,157 @@
|
||||
(* Utility types and functions *)
|
||||
|
||||
(* Identity *)
|
||||
|
||||
let id x = x
|
||||
|
||||
(* Combinators *)
|
||||
|
||||
let (<@) f g x = f (g x)
|
||||
|
||||
let swap f x y = f y x
|
||||
|
||||
let lambda = fun x _ -> x
|
||||
|
||||
let curry f x y = f (x,y)
|
||||
let uncurry f (x,y) = f x y
|
||||
|
||||
(* Parametric rules for sequences *)
|
||||
|
||||
type 'a nseq = 'a * 'a list
|
||||
type ('a,'sep) nsepseq = 'a * ('sep * 'a) list
|
||||
type ('a,'sep) sepseq = ('a,'sep) nsepseq option
|
||||
|
||||
(* Consing *)
|
||||
|
||||
let nseq_cons x (hd,tl) = x, hd::tl
|
||||
let nsepseq_cons x sep (hd,tl) = x, (sep,hd)::tl
|
||||
|
||||
let sepseq_cons x sep = function
|
||||
None -> x, []
|
||||
| Some (hd,tl) -> x, (sep,hd)::tl
|
||||
|
||||
(* Rightwards iterators *)
|
||||
|
||||
let nseq_foldl f a (hd,tl) = List.fold_left f a (hd::tl)
|
||||
|
||||
let nsepseq_foldl f a (hd,tl) =
|
||||
List.fold_left (fun a (_,e) -> f a e) (f a hd) tl
|
||||
|
||||
let sepseq_foldl f a = function
|
||||
None -> a
|
||||
| Some s -> nsepseq_foldl f a s
|
||||
|
||||
let nseq_iter f (hd,tl) = List.iter f (hd::tl)
|
||||
|
||||
let nsepseq_iter f (hd,tl) = f hd; List.iter (f <@ snd) tl
|
||||
|
||||
let sepseq_iter f = function
|
||||
None -> ()
|
||||
| Some s -> nsepseq_iter f s
|
||||
|
||||
(* Reversing *)
|
||||
|
||||
let nseq_rev (hd,tl) =
|
||||
let rec aux acc = function
|
||||
[] -> acc
|
||||
| x::l -> aux (nseq_cons x acc) l
|
||||
in aux (hd,[]) tl
|
||||
|
||||
let nsepseq_rev =
|
||||
let rec aux acc = function
|
||||
hd, (sep,snd)::tl -> aux ((sep,hd)::acc) (snd,tl)
|
||||
| hd, [] -> hd, acc in
|
||||
function
|
||||
hd, (sep,snd)::tl -> aux [sep,hd] (snd,tl)
|
||||
| s -> s
|
||||
|
||||
let sepseq_rev = function
|
||||
None -> None
|
||||
| Some seq -> Some (nsepseq_rev seq)
|
||||
|
||||
(* Leftwards iterators *)
|
||||
|
||||
let nseq_foldr f (hd,tl) = List.fold_right f (hd::tl)
|
||||
|
||||
let nsepseq_foldr f (hd,tl) a = f hd (List.fold_right (f <@ snd) tl a)
|
||||
|
||||
let sepseq_foldr f = function
|
||||
None -> fun a -> a
|
||||
| Some s -> nsepseq_foldr f s
|
||||
|
||||
(* Conversions to lists *)
|
||||
|
||||
let nseq_to_list (x,y) = x::y
|
||||
|
||||
let nsepseq_to_list (x,y) = x :: List.map snd y
|
||||
|
||||
let sepseq_to_list = function
|
||||
None -> []
|
||||
| Some s -> nsepseq_to_list s
|
||||
|
||||
(* Optional values *)
|
||||
|
||||
module Option =
|
||||
struct
|
||||
let apply f x =
|
||||
match x with
|
||||
Some y -> Some (f y)
|
||||
| None -> None
|
||||
|
||||
let rev_apply x y =
|
||||
match x with
|
||||
Some f -> f y
|
||||
| None -> y
|
||||
|
||||
let to_string = function
|
||||
Some x -> x
|
||||
| None -> ""
|
||||
end
|
||||
|
||||
(* Modules based on [String], like sets and maps. *)
|
||||
|
||||
module String =
|
||||
struct
|
||||
include String
|
||||
|
||||
module Ord =
|
||||
struct
|
||||
type nonrec t = t
|
||||
let compare = compare
|
||||
end
|
||||
|
||||
module Map = Map.Make (Ord)
|
||||
module Set = Set.Make (Ord)
|
||||
end
|
||||
|
||||
(* Integers *)
|
||||
|
||||
module Int =
|
||||
struct
|
||||
type t = int
|
||||
|
||||
module Ord =
|
||||
struct
|
||||
type nonrec t = t
|
||||
let compare = compare
|
||||
end
|
||||
|
||||
module Map = Map.Make (Ord)
|
||||
module Set = Set.Make (Ord)
|
||||
end
|
||||
|
||||
(* Effectful symbol generator *)
|
||||
|
||||
let gen_sym =
|
||||
let counter = ref 0 in
|
||||
fun () -> incr counter; "v" ^ string_of_int !counter
|
||||
|
||||
(* General tracing function *)
|
||||
|
||||
let trace text = function
|
||||
None -> ()
|
||||
| Some chan -> output_string chan text; flush chan
|
||||
|
||||
(* Printing a string in red to standard error *)
|
||||
|
||||
let highlight msg = Printf.eprintf "\027[31m%s\027[0m%!" msg
|
||||
97
src/ligo/parser/Utils.mli
Normal file
97
src/ligo/parser/Utils.mli
Normal file
@ -0,0 +1,97 @@
|
||||
(* Utility types and functions *)
|
||||
|
||||
(* Polymorphic identity function *)
|
||||
|
||||
val id : 'a -> 'a
|
||||
|
||||
(* Combinators *)
|
||||
|
||||
val ( <@ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
|
||||
val swap : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
|
||||
val lambda : 'a -> 'b -> 'a
|
||||
val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
|
||||
val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
|
||||
|
||||
(* Parametric rules for sequences
|
||||
|
||||
nseq: non-empty sequence;
|
||||
sepseq: (possibly empty) sequence of separated items;
|
||||
nsepseq: non-empty sequence of separated items.
|
||||
*)
|
||||
|
||||
type 'a nseq = 'a * 'a list
|
||||
type ('a,'sep) nsepseq = 'a * ('sep * 'a) list
|
||||
type ('a,'sep) sepseq = ('a,'sep) nsepseq option
|
||||
|
||||
(* Consing *)
|
||||
|
||||
val nseq_cons : 'a -> 'a nseq -> 'a nseq
|
||||
val nsepseq_cons : 'a -> 'sep -> ('a,'sep) nsepseq -> ('a,'sep) nsepseq
|
||||
val sepseq_cons : 'a -> 'sep -> ('a,'sep) sepseq -> ('a,'sep) nsepseq
|
||||
|
||||
(* Reversing *)
|
||||
|
||||
val nseq_rev: 'a nseq -> 'a nseq
|
||||
val nsepseq_rev: ('a,'sep) nsepseq -> ('a,'sep) nsepseq
|
||||
val sepseq_rev: ('a,'sep) sepseq -> ('a,'sep) sepseq
|
||||
|
||||
(* Rightwards iterators *)
|
||||
|
||||
val nseq_foldl : ('a -> 'b -> 'a) -> 'a -> 'b nseq -> 'a
|
||||
val nsepseq_foldl : ('a -> 'b -> 'a) -> 'a -> ('b,'c) nsepseq -> 'a
|
||||
val sepseq_foldl : ('a -> 'b -> 'a) -> 'a -> ('b,'c) sepseq -> 'a
|
||||
|
||||
val nseq_iter : ('a -> unit) -> 'a nseq -> unit
|
||||
val nsepseq_iter : ('a -> unit) -> ('a,'b) nsepseq -> unit
|
||||
val sepseq_iter : ('a -> unit) -> ('a,'b) sepseq -> unit
|
||||
|
||||
(* Leftwards iterators *)
|
||||
|
||||
val nseq_foldr : ('a -> 'b -> 'b) -> 'a nseq -> 'b -> 'b
|
||||
val nsepseq_foldr : ('a -> 'b -> 'b) -> ('a,'c) nsepseq -> 'b -> 'b
|
||||
val sepseq_foldr : ('a -> 'b -> 'b) -> ('a,'c) sepseq -> 'b -> 'b
|
||||
|
||||
(* Conversions to lists *)
|
||||
|
||||
val nseq_to_list : 'a nseq -> 'a list
|
||||
val nsepseq_to_list : ('a,'b) nsepseq -> 'a list
|
||||
val sepseq_to_list : ('a,'b) sepseq -> 'a list
|
||||
|
||||
(* Effectful symbol generator *)
|
||||
|
||||
val gen_sym : unit -> string
|
||||
|
||||
(* General tracing function *)
|
||||
|
||||
val trace : string -> out_channel option -> unit
|
||||
|
||||
(* Printing a string in red to standard error *)
|
||||
|
||||
val highlight : string -> unit
|
||||
|
||||
(* Working with optional values *)
|
||||
|
||||
module Option :
|
||||
sig
|
||||
val apply : ('a -> 'b) -> 'a option -> 'b option
|
||||
val rev_apply : ('a -> 'a) option -> 'a -> 'a
|
||||
val to_string : string option -> string
|
||||
end
|
||||
|
||||
(* An extension to the standard module [String] *)
|
||||
|
||||
module String :
|
||||
sig
|
||||
include module type of String
|
||||
module Map : Map.S with type key = t
|
||||
module Set : Set.S with type elt = t
|
||||
end
|
||||
|
||||
(* Integer maps *)
|
||||
|
||||
module Int :
|
||||
sig
|
||||
type t = int
|
||||
module Map : Map.S with type key = t
|
||||
module Set : Set.S with type elt = t
|
||||
end
|
||||
1
src/ligo/parser/Version.ml
Normal file
1
src/ligo/parser/Version.ml
Normal file
@ -0,0 +1 @@
|
||||
let version = "84dbf1f7eee30a9d3f8a8363efa5b6f04e7c2f36"
|
||||
10
src/ligo/parser/check_dot_git_is_dir.sh
Executable file
10
src/ligo/parser/check_dot_git_is_dir.sh
Executable file
@ -0,0 +1,10 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -e
|
||||
|
||||
if test -d ../../.git; then
|
||||
echo true > dot_git_is_dir
|
||||
else
|
||||
echo false > dot_git_is_dir
|
||||
cat .git >> dot_git_is_dir
|
||||
fi
|
||||
29
src/ligo/parser/dune
Normal file
29
src/ligo/parser/dune
Normal file
@ -0,0 +1,29 @@
|
||||
(ocamllex LexToken)
|
||||
(ocamllex Lexer)
|
||||
|
||||
(menhir
|
||||
(merge_into Parser)
|
||||
(modules ParToken Parser)
|
||||
(flags -la 1 --explain --external-tokens LexToken))
|
||||
|
||||
(executables
|
||||
(names LexerMain ParserMain)
|
||||
(public_names ligo-lexer ligo-parser)
|
||||
(package ligo-parser)
|
||||
(modules_without_implementation Error)
|
||||
(libraries getopt hex str uutf zarith))
|
||||
|
||||
;; Les deux directives (rule) qui suivent sont pour le dev local.
|
||||
;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier.
|
||||
;; Pour le purger, il faut faire "dune clean".
|
||||
(rule
|
||||
(targets Parser.exe)
|
||||
(deps ParserMain.exe)
|
||||
(action (copy ParserMain.exe Parser.exe))
|
||||
(mode promote-until-clean))
|
||||
|
||||
(rule
|
||||
(targets Lexer.exe)
|
||||
(deps LexerMain.exe)
|
||||
(action (copy LexerMain.exe Lexer.exe))
|
||||
(mode promote-until-clean))
|
||||
19
src/ligo/parser/ligo-parser.opam
Normal file
19
src/ligo/parser/ligo-parser.opam
Normal file
@ -0,0 +1,19 @@
|
||||
opam-version : "2.0"
|
||||
version : "1.0"
|
||||
maintainer : "gabriel.alfour@gmail.com"
|
||||
authors : [ "Galfour" ]
|
||||
homepage : "https://gitlab.com/gabriel.alfour/tezos"
|
||||
bug-reports : "https://gitlab.com/gabriel.alfour/tezos/issues"
|
||||
dev-repo : "git+https://gitlab.com/gabriel.alfour/tezos.git"
|
||||
license : "MIT"
|
||||
|
||||
depends : [ "dune" "menhir" "hex" "zarith" "getopt" "uutf" ]
|
||||
|
||||
build : [
|
||||
[ "sh" "-c" "printf 'let version = \"%s\"' \"$(git describe --always --dirty --abbrev=0)\" > Version.ml" ]
|
||||
[ "dune" "build" "-p" name "-j" jobs ]
|
||||
]
|
||||
|
||||
url {
|
||||
src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
|
||||
}
|
||||
229
src/ligo/parser/typecheck.ml
Normal file
229
src/ligo/parser/typecheck.ml
Normal file
@ -0,0 +1,229 @@
|
||||
(* module I = AST (\* In *\) *)
|
||||
|
||||
(* module SMap = Map.Make(String) *)
|
||||
|
||||
(* type te = type_expr list SMap.t *)
|
||||
(* type ve = type_expr list SMap.t *)
|
||||
(* type tve = te * ve *)
|
||||
|
||||
(*
|
||||
module I = AST (* In *)
|
||||
|
||||
module SMap = Map.Make(String)
|
||||
|
||||
module O = struct
|
||||
open AST (* TODO: for now, should disappear *)
|
||||
|
||||
type t = ast
|
||||
|
||||
and type_expr =
|
||||
Prod of cartesian
|
||||
| Sum of (variant, vbar) Utils.nsepseq
|
||||
| Record of record_type
|
||||
| TypeApp of (type_name * type_tuple)
|
||||
| ParType of type_expr par
|
||||
| TAlias of variable
|
||||
| Function of (type_expr list) * type_expr
|
||||
| Mutable of type_expr
|
||||
| Unit
|
||||
| TODO of string
|
||||
|
||||
and te = type_expr list SMap.t
|
||||
|
||||
and ve = type_expr list SMap.t
|
||||
|
||||
and vte = ve * te
|
||||
|
||||
and ast = {
|
||||
lambdas : lambda_decl list;
|
||||
block : block
|
||||
}
|
||||
|
||||
and lambda_decl =
|
||||
FunDecl of fun_decl
|
||||
| ProcDecl of proc_decl
|
||||
|
||||
and fun_decl = {
|
||||
kwd_function : kwd_function;
|
||||
var : variable;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
kwd_is : kwd_is;
|
||||
body : block;
|
||||
kwd_with : kwd_with;
|
||||
return : checked_expr
|
||||
}
|
||||
|
||||
and proc_decl = {
|
||||
kwd_procedure : kwd_procedure;
|
||||
var : variable;
|
||||
param : parameters;
|
||||
kwd_is : kwd_is;
|
||||
body : block
|
||||
}
|
||||
|
||||
and block = {
|
||||
decls : value_decls;
|
||||
opening : kwd_begin;
|
||||
instr : instructions;
|
||||
close : kwd_end
|
||||
}
|
||||
|
||||
and value_decls = var_decl list
|
||||
|
||||
and var_decl = {
|
||||
kind : var_kind;
|
||||
var : variable;
|
||||
colon : colon;
|
||||
vtype : type_expr;
|
||||
setter : Region.t; (* "=" or ":=" *)
|
||||
init : checked_expr
|
||||
}
|
||||
|
||||
and checked_expr = {ty:type_expr;expr:expr}
|
||||
end [@warning "-30"]
|
||||
|
||||
open O
|
||||
open AST
|
||||
open Region
|
||||
|
||||
let mk_checked_expr ~ty ~expr = {ty;expr}
|
||||
let mk_proc_decl ~kwd_procedure ~var ~param ~kwd_is ~body =
|
||||
O.{kwd_procedure; var; param; kwd_is; body}
|
||||
let mk_ast ~lambdas ~block = {lambdas;block}
|
||||
let mk_fun_decl ~kwd_function ~var ~param ~colon ~ret_type ~kwd_is ~body ~kwd_with ~return =
|
||||
O.{kwd_function; var; param; colon; ret_type; kwd_is; body; kwd_with; return}
|
||||
|
||||
|
||||
let unreg : 'a reg -> 'a = fun {value; _} -> value
|
||||
let unpar : 'a par -> 'a = (fun (_left_par, x, _right_par) -> x) @. unreg
|
||||
let nsepseq_to_list : ('a,'sep) Utils.nsepseq -> 'a list =
|
||||
fun (first, rest) -> first :: (map snd rest)
|
||||
let sepseq_to_list : ('a,'sep) Utils.sepseq -> 'a list =
|
||||
function
|
||||
None -> []
|
||||
| Some nsepseq -> nsepseq_to_list nsepseq
|
||||
|
||||
let rec xty : I.type_expr -> O.type_expr =
|
||||
function
|
||||
I.Prod x -> O.Prod x
|
||||
| I.Sum x -> O.Sum (unreg x)
|
||||
| I.Record x -> O.Record x
|
||||
| I.TypeApp x -> O.TypeApp (unreg x)
|
||||
| I.ParType {region;value=(l,x,r)} -> O.ParType {region;value=(l, xty x, r)}
|
||||
| I.TAlias x -> O.TAlias x
|
||||
|
||||
let shadow (name : string) (typ : O.type_expr) (env : O.type_expr list SMap.t)
|
||||
: O.type_expr list SMap.t =
|
||||
SMap.update name (function None -> Some [typ] | Some tl -> Some (typ :: tl)) env
|
||||
|
||||
let shadow_list (name_typ_list : (string * O.type_expr) list) (env : O.type_expr list SMap.t)
|
||||
: O.type_expr list SMap.t =
|
||||
List.fold_left (fun acc (name, typ) -> shadow name typ acc) env name_typ_list
|
||||
|
||||
let type_decls_to_tenv (td : I.type_decl list) (te : te) : O.te =
|
||||
td
|
||||
|> List.map unreg
|
||||
|> List.map (fun (_, name, _, type_expr) -> (unreg name, xty type_expr))
|
||||
|> fun up -> shadow_list up te
|
||||
|
||||
let var_kind_to_ty : var_kind -> I.type_expr -> O.type_expr =
|
||||
fun var_kind ty ->
|
||||
match var_kind with
|
||||
Mutable _ -> O.Mutable (xty ty)
|
||||
| Const _ -> xty ty
|
||||
|
||||
let params_to_xty params ret_type =
|
||||
unpar params
|
||||
|> nsepseq_to_list
|
||||
|> map (fun {value=(var_kind, _variable, _colon, type_expr);_} -> var_kind_to_ty var_kind type_expr)
|
||||
|> fun param_types -> O.Function (param_types, ret_type)
|
||||
|
||||
let type_equal t1 t2 = match t1,t2 with
|
||||
| O.Prod _x, O.Prod _y -> true (* TODO *)
|
||||
| O.Sum _x, O.Sum _y -> true (* TODO *)
|
||||
| _ -> false
|
||||
|
||||
exception TypeError of string
|
||||
|
||||
let check_type expr expected_type =
|
||||
if type_equal expr.ty expected_type then expr
|
||||
else raise (TypeError "oops")
|
||||
|
||||
let tc_expr (_te,_ve) expr = mk_checked_expr ~ty:(TODO "all expressions") ~expr (* TODO *)
|
||||
|
||||
let tc_var_decl : vte -> I.var_decl -> vte * O.var_decl =
|
||||
fun (ve,te) var_decl ->
|
||||
let vtype = (xty var_decl.vtype) in
|
||||
let init = check_type (tc_expr (te,ve) var_decl.init) vtype in
|
||||
let ve = shadow (unreg var_decl.var) vtype ve in
|
||||
(ve,te), {
|
||||
kind = var_decl.kind;
|
||||
var = var_decl.var;
|
||||
colon = var_decl.colon;
|
||||
vtype;
|
||||
setter = var_decl.setter;
|
||||
init}
|
||||
|
||||
let tc_var_decls (ve,te) var_decls = fold_map tc_var_decl (ve,te) var_decls
|
||||
|
||||
let tc_block (te, ve : vte) (block : I.block) : vte * O.block =
|
||||
let decls,opening,instr,close = block.decls, block.opening, block.instr, block.close in
|
||||
let (ve,te), decls = tc_var_decls (ve,te) (decls |> unreg |> sepseq_to_list |> map unreg) in
|
||||
(ve,te), O.{decls;opening;instr;close} (* TODO *)
|
||||
|
||||
let tc_proc_decl : vte -> I.proc_decl -> O.proc_decl =
|
||||
fun vte proc_decl ->
|
||||
let _vte', block' = tc_block vte (unreg proc_decl.body)
|
||||
in mk_proc_decl
|
||||
~kwd_procedure: proc_decl.kwd_procedure
|
||||
~kwd_is: proc_decl.kwd_is
|
||||
~var: proc_decl.var
|
||||
~param: proc_decl.param
|
||||
~body: block'
|
||||
|
||||
let tc_fun_decl : vte -> I.fun_decl -> O.fun_decl =
|
||||
fun vte fun_decl ->
|
||||
let vte', block' = tc_block vte (unreg fun_decl.body) in
|
||||
let return' = tc_expr vte' fun_decl.return in
|
||||
let checked_return' = check_type return' (xty fun_decl.ret_type)
|
||||
in mk_fun_decl
|
||||
~kwd_function: fun_decl.kwd_function
|
||||
~colon: fun_decl.colon
|
||||
~kwd_is: fun_decl.kwd_is
|
||||
~kwd_with: fun_decl.kwd_with
|
||||
~var: fun_decl.var
|
||||
~param: fun_decl.param
|
||||
~ret_type: (xty fun_decl.ret_type)
|
||||
~body: block'
|
||||
~return: checked_return'
|
||||
|
||||
let ve_lambda_decl : vte -> I.lambda_decl -> ve =
|
||||
fun (ve,_te) ->
|
||||
function
|
||||
FunDecl {value;_} -> shadow value.var.value (params_to_xty value.param (xty value.ret_type)) ve
|
||||
| ProcDecl {value;_} -> shadow value.var.value (params_to_xty value.param Unit) ve
|
||||
|
||||
let tc_lambda_decl (ve, te : vte) (whole : I.lambda_decl) : vte * O.lambda_decl =
|
||||
match whole with
|
||||
FunDecl {value;_} -> ((ve_lambda_decl (ve, te) whole), te), O.FunDecl (tc_fun_decl (ve, te) value)
|
||||
| ProcDecl {value;_} -> ((ve_lambda_decl (ve, te) whole), te), O.ProcDecl (tc_proc_decl (ve, te) value)
|
||||
|
||||
let tc_ast (ast : I.ast) : O.ast =
|
||||
(* te is the type environment, ve is the variable environment *)
|
||||
let te =
|
||||
SMap.empty
|
||||
|> type_decls_to_tenv ast.types in
|
||||
let ve =
|
||||
SMap.empty
|
||||
|> (match ast.parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty)
|
||||
|> shadow "storage" @@ xty (snd ast.storage.value)
|
||||
|> shadow "operations" @@ xty (snd ast.operations.value)
|
||||
in
|
||||
let (ve',te'), lambdas = fold_map tc_lambda_decl (ve, te) ast.lambdas in
|
||||
let (ve'', te''), block = tc_block (ve', te') (unreg ast.block) in
|
||||
let _ve'' = ve'' in (* not needed anymore *)
|
||||
let _te'' = te'' in (* not needed anymore *)
|
||||
mk_ast ~lambdas ~block
|
||||
*)
|
||||
Loading…
Reference in New Issue
Block a user