Threaded 'a parameter everywhere
This commit is contained in:
Your Name
parent
09f790680f
commit
40377a80df
411
AST.mli
411
AST.mli
@ -97,12 +97,12 @@ type eof = Region.t
|
|||||||
|
|
||||||
(* Literals *)
|
(* Literals *)
|
||||||
|
|
||||||
type variable = string reg
|
type 'a variable = string reg
|
||||||
type fun_name = string reg
|
type 'a fun_name = string reg
|
||||||
type type_name = string reg
|
type 'a type_name = string reg
|
||||||
type field_name = string reg
|
type 'a field_name = string reg
|
||||||
type map_name = string reg
|
type 'a map_name = string reg
|
||||||
type constr = string reg
|
type 'a constr = string reg
|
||||||
|
|
||||||
(* Comma-separated non-empty lists *)
|
(* Comma-separated non-empty lists *)
|
||||||
|
|
||||||
@ -126,229 +126,229 @@ type 'a braces = (lbrace * 'a * rbrace) reg
|
|||||||
|
|
||||||
(* The Abstract Syntax Tree *)
|
(* The Abstract Syntax Tree *)
|
||||||
|
|
||||||
type t = {
|
type t = < ty:unit > ast
|
||||||
types : type_decl reg list;
|
|
||||||
constants : const_decl reg list;
|
and 'a ast = {
|
||||||
parameter : parameter_decl reg;
|
types : 'a type_decl reg list;
|
||||||
storage : storage_decl reg;
|
constants : 'a const_decl reg list;
|
||||||
operations : operations_decl reg;
|
parameter : 'a parameter_decl reg;
|
||||||
lambdas : lambda_decl list;
|
storage : 'a storage_decl reg;
|
||||||
block : block reg;
|
operations : 'a operations_decl reg;
|
||||||
|
lambdas : 'a lambda_decl list;
|
||||||
|
block : 'a block reg;
|
||||||
eof : eof
|
eof : eof
|
||||||
}
|
}
|
||||||
|
|
||||||
and ast = t
|
and 'a parameter_decl = {
|
||||||
|
|
||||||
and parameter_decl = {
|
|
||||||
kwd_parameter : kwd_parameter;
|
kwd_parameter : kwd_parameter;
|
||||||
name : variable;
|
name : 'a variable;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
param_type : type_expr;
|
param_type : 'a type_expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and storage_decl = {
|
and 'a storage_decl = {
|
||||||
kwd_storage : kwd_storage;
|
kwd_storage : kwd_storage;
|
||||||
store_type : type_expr;
|
store_type : 'a type_expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and operations_decl = {
|
and 'a operations_decl = {
|
||||||
kwd_operations : kwd_operations;
|
kwd_operations : kwd_operations;
|
||||||
op_type : type_expr;
|
op_type : 'a type_expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
(* Type declarations *)
|
(* Type declarations *)
|
||||||
|
|
||||||
and type_decl = {
|
and 'a type_decl = {
|
||||||
kwd_type : kwd_type;
|
kwd_type : kwd_type;
|
||||||
name : type_name;
|
name : 'a type_name;
|
||||||
kwd_is : kwd_is;
|
kwd_is : kwd_is;
|
||||||
type_expr : type_expr;
|
type_expr : 'a type_expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and type_expr =
|
and 'a type_expr =
|
||||||
Prod of cartesian
|
Prod of 'a cartesian
|
||||||
| Sum of (variant, vbar) nsepseq reg
|
| Sum of ('a variant, vbar) nsepseq reg
|
||||||
| Record of record_type
|
| Record of 'a record_type
|
||||||
| TypeApp of (type_name * type_tuple) reg
|
| TypeApp of ('a type_name * 'a type_tuple) reg
|
||||||
| ParType of type_expr par
|
| ParType of 'a type_expr par
|
||||||
| TAlias of variable
|
| TAlias of 'a variable
|
||||||
|
|
||||||
and cartesian = (type_expr, times) nsepseq reg
|
and 'a cartesian = ('a type_expr, times) nsepseq reg
|
||||||
|
|
||||||
and variant = (constr * kwd_of * cartesian) reg
|
and 'a variant = ('a constr * kwd_of * 'a cartesian) reg
|
||||||
|
|
||||||
and record_type = (kwd_record * field_decls * kwd_end) reg
|
and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg
|
||||||
|
|
||||||
and field_decls = (field_decl, semi) nsepseq
|
and 'a field_decls = ('a field_decl, semi) nsepseq
|
||||||
|
|
||||||
and field_decl = (variable * colon * type_expr) reg
|
and 'a field_decl = ('a variable * colon * 'a type_expr) reg
|
||||||
|
|
||||||
and type_tuple = (type_name, comma) nsepseq par
|
and 'a type_tuple = ('a type_name, comma) nsepseq par
|
||||||
|
|
||||||
(* Function and procedure declarations *)
|
(* Function and procedure declarations *)
|
||||||
|
|
||||||
and lambda_decl =
|
and 'a lambda_decl =
|
||||||
FunDecl of fun_decl reg
|
FunDecl of 'a fun_decl reg
|
||||||
| ProcDecl of proc_decl reg
|
| ProcDecl of 'a proc_decl reg
|
||||||
|
|
||||||
and fun_decl = {
|
and 'a fun_decl = {
|
||||||
kwd_function : kwd_function;
|
kwd_function : kwd_function;
|
||||||
name : variable;
|
name : 'a variable;
|
||||||
param : parameters;
|
param : 'a parameters;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
ret_type : type_expr;
|
ret_type : 'a type_expr;
|
||||||
kwd_is : kwd_is;
|
kwd_is : kwd_is;
|
||||||
local_decls : local_decl list;
|
local_decls : 'a local_decl list;
|
||||||
block : block reg;
|
block : 'a block reg;
|
||||||
kwd_with : kwd_with;
|
kwd_with : kwd_with;
|
||||||
return : expr;
|
return : 'a expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and proc_decl = {
|
and 'a proc_decl = {
|
||||||
kwd_procedure : kwd_procedure;
|
kwd_procedure : kwd_procedure;
|
||||||
name : variable;
|
name : 'a variable;
|
||||||
param : parameters;
|
param : 'a parameters;
|
||||||
kwd_is : kwd_is;
|
kwd_is : kwd_is;
|
||||||
local_decls : local_decl list;
|
local_decls : 'a local_decl list;
|
||||||
block : block reg;
|
block : 'a block reg;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and parameters = (param_decl, semi) nsepseq par
|
and 'a parameters = ('a param_decl, semi) nsepseq par
|
||||||
|
|
||||||
and param_decl =
|
and 'a param_decl =
|
||||||
ParamConst of param_const
|
ParamConst of 'a param_const
|
||||||
| ParamVar of param_var
|
| ParamVar of 'a param_var
|
||||||
|
|
||||||
and param_const = (kwd_const * variable * colon * type_expr) reg
|
and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg
|
||||||
|
|
||||||
and param_var = (kwd_var * variable * colon * type_expr) reg
|
and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg
|
||||||
|
|
||||||
and block = {
|
and 'a block = {
|
||||||
opening : kwd_begin;
|
opening : kwd_begin;
|
||||||
instr : instructions;
|
instr : 'a instructions;
|
||||||
terminator : semi option;
|
terminator : semi option;
|
||||||
close : kwd_end
|
close : kwd_end
|
||||||
}
|
}
|
||||||
|
|
||||||
and local_decl =
|
and 'a local_decl =
|
||||||
LocalLam of lambda_decl
|
LocalLam of 'a lambda_decl
|
||||||
| LocalConst of const_decl reg
|
| LocalConst of 'a const_decl reg
|
||||||
| LocalVar of var_decl reg
|
| LocalVar of 'a var_decl reg
|
||||||
|
|
||||||
and const_decl = {
|
and 'a const_decl = {
|
||||||
kwd_const : kwd_const;
|
kwd_const : kwd_const;
|
||||||
name : variable;
|
name : 'a variable;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
vtype : type_expr;
|
vtype : 'a type_expr;
|
||||||
equal : equal;
|
equal : equal;
|
||||||
init : expr;
|
init : 'a expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and var_decl = {
|
and 'a var_decl = {
|
||||||
kwd_var : kwd_var;
|
kwd_var : kwd_var;
|
||||||
name : variable;
|
name : 'a variable;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
vtype : type_expr;
|
vtype : 'a type_expr;
|
||||||
ass : ass;
|
ass : ass;
|
||||||
init : expr;
|
init : 'a expr;
|
||||||
terminator : semi option
|
terminator : semi option
|
||||||
}
|
}
|
||||||
|
|
||||||
and instructions = (instruction, semi) nsepseq reg
|
and 'a instructions = ('a instruction, semi) nsepseq reg
|
||||||
|
|
||||||
and instruction =
|
and 'a instruction =
|
||||||
Single of single_instr
|
Single of 'a single_instr
|
||||||
| Block of block reg
|
| Block of 'a block reg
|
||||||
|
|
||||||
and single_instr =
|
and 'a single_instr =
|
||||||
Cond of conditional reg
|
Cond of 'a conditional reg
|
||||||
| Match of match_instr reg
|
| Match of 'a match_instr reg
|
||||||
| Ass of ass_instr
|
| Ass of 'a ass_instr
|
||||||
| Loop of loop
|
| Loop of 'a loop
|
||||||
| ProcCall of fun_call
|
| ProcCall of 'a fun_call
|
||||||
| Null of kwd_null
|
| Null of kwd_null
|
||||||
| Fail of (kwd_fail * expr) reg
|
| Fail of (kwd_fail * 'a expr) reg
|
||||||
|
|
||||||
and conditional = {
|
and 'a conditional = {
|
||||||
kwd_if : kwd_if;
|
kwd_if : kwd_if;
|
||||||
test : expr;
|
test : 'a expr;
|
||||||
kwd_then : kwd_then;
|
kwd_then : kwd_then;
|
||||||
ifso : instruction;
|
ifso : 'a instruction;
|
||||||
kwd_else : kwd_else;
|
kwd_else : kwd_else;
|
||||||
ifnot : instruction
|
ifnot : 'a instruction
|
||||||
}
|
}
|
||||||
|
|
||||||
and match_instr = {
|
and 'a match_instr = {
|
||||||
kwd_match : kwd_match;
|
kwd_match : kwd_match;
|
||||||
expr : expr;
|
expr : 'a expr;
|
||||||
kwd_with : kwd_with;
|
kwd_with : kwd_with;
|
||||||
lead_vbar : vbar option;
|
lead_vbar : vbar option;
|
||||||
cases : cases;
|
cases : 'a cases;
|
||||||
kwd_end : kwd_end
|
kwd_end : kwd_end
|
||||||
}
|
}
|
||||||
|
|
||||||
and cases = (case, vbar) nsepseq reg
|
and 'a cases = ('a case, vbar) nsepseq reg
|
||||||
|
|
||||||
and case = (pattern * arrow * instruction) reg
|
and 'a case = ('a pattern * arrow * 'a instruction) reg
|
||||||
|
|
||||||
and ass_instr = (variable * ass * expr) reg
|
and 'a ass_instr = ('a variable * ass * 'a expr) reg
|
||||||
|
|
||||||
and loop =
|
and 'a loop =
|
||||||
While of while_loop
|
While of 'a while_loop
|
||||||
| For of for_loop
|
| For of 'a for_loop
|
||||||
|
|
||||||
and while_loop = (kwd_while * expr * block reg) reg
|
and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg
|
||||||
|
|
||||||
and for_loop =
|
and 'a for_loop =
|
||||||
ForInt of for_int reg
|
ForInt of 'a for_int reg
|
||||||
| ForCollect of for_collect reg
|
| ForCollect of 'a for_collect reg
|
||||||
|
|
||||||
and for_int = {
|
and 'a for_int = {
|
||||||
kwd_for : kwd_for;
|
kwd_for : kwd_for;
|
||||||
ass : ass_instr;
|
ass : 'a ass_instr;
|
||||||
down : kwd_down option;
|
down : kwd_down option;
|
||||||
kwd_to : kwd_to;
|
kwd_to : kwd_to;
|
||||||
bound : expr;
|
bound : 'a expr;
|
||||||
step : (kwd_step * expr) option;
|
step : (kwd_step * 'a expr) option;
|
||||||
block : block reg
|
block : 'a block reg
|
||||||
}
|
}
|
||||||
|
|
||||||
and for_collect = {
|
and 'a for_collect = {
|
||||||
kwd_for : kwd_for;
|
kwd_for : kwd_for;
|
||||||
var : variable;
|
var : 'a variable;
|
||||||
bind_to : (arrow * variable) option;
|
bind_to : (arrow * 'a variable) option;
|
||||||
kwd_in : kwd_in;
|
kwd_in : kwd_in;
|
||||||
expr : expr;
|
expr : 'a expr;
|
||||||
block : block reg
|
block : 'a block reg
|
||||||
}
|
}
|
||||||
|
|
||||||
(* Expressions *)
|
(* Expressions *)
|
||||||
|
|
||||||
and expr =
|
and 'a expr =
|
||||||
Or of (expr * bool_or * expr) reg
|
Or of ('a expr * bool_or * 'a expr) reg
|
||||||
| And of (expr * bool_and * expr) reg
|
| And of ('a expr * bool_and * 'a expr) reg
|
||||||
| Lt of (expr * lt * expr) reg
|
| Lt of ('a expr * lt * 'a expr) reg
|
||||||
| Leq of (expr * leq * expr) reg
|
| Leq of ('a expr * leq * 'a expr) reg
|
||||||
| Gt of (expr * gt * expr) reg
|
| Gt of ('a expr * gt * 'a expr) reg
|
||||||
| Geq of (expr * geq * expr) reg
|
| Geq of ('a expr * geq * 'a expr) reg
|
||||||
| Equal of (expr * equal * expr) reg
|
| Equal of ('a expr * equal * 'a expr) reg
|
||||||
| Neq of (expr * neq * expr) reg
|
| Neq of ('a expr * neq * 'a expr) reg
|
||||||
| Cat of (expr * cat * expr) reg
|
| Cat of ('a expr * cat * 'a expr) reg
|
||||||
| Cons of (expr * cons * expr) reg
|
| Cons of ('a expr * cons * 'a expr) reg
|
||||||
| Add of (expr * plus * expr) reg
|
| Add of ('a expr * plus * 'a expr) reg
|
||||||
| Sub of (expr * minus * expr) reg
|
| Sub of ('a expr * minus * 'a expr) reg
|
||||||
| Mult of (expr * times * expr) reg
|
| Mult of ('a expr * times * 'a expr) reg
|
||||||
| Div of (expr * slash * expr) reg
|
| Div of ('a expr * slash * 'a expr) reg
|
||||||
| Mod of (expr * kwd_mod * expr) reg
|
| Mod of ('a expr * kwd_mod * 'a expr) reg
|
||||||
| Neg of (minus * expr) reg
|
| Neg of (minus * 'a expr) reg
|
||||||
| Not of (kwd_not * expr) reg
|
| Not of (kwd_not * 'a expr) reg
|
||||||
| Int of (Lexer.lexeme * Z.t) reg
|
| Int of (Lexer.lexeme * Z.t) reg
|
||||||
| Var of Lexer.lexeme reg
|
| Var of Lexer.lexeme reg
|
||||||
| String of Lexer.lexeme reg
|
| String of Lexer.lexeme reg
|
||||||
@ -356,46 +356,46 @@ and expr =
|
|||||||
| False of c_False
|
| False of c_False
|
||||||
| True of c_True
|
| True of c_True
|
||||||
| Unit of c_Unit
|
| Unit of c_Unit
|
||||||
| Tuple of tuple
|
| Tuple of 'a tuple
|
||||||
| List of (expr, comma) nsepseq brackets
|
| List of ('a expr, comma) nsepseq brackets
|
||||||
| EmptyList of empty_list
|
| EmptyList of 'a empty_list
|
||||||
| Set of (expr, comma) nsepseq braces
|
| Set of ('a expr, comma) nsepseq braces
|
||||||
| EmptySet of empty_set
|
| EmptySet of 'a empty_set
|
||||||
| NoneExpr of none_expr
|
| NoneExpr of 'a none_expr
|
||||||
| FunCall of fun_call
|
| FunCall of 'a fun_call
|
||||||
| ConstrApp of constr_app
|
| ConstrApp of 'a constr_app
|
||||||
| SomeApp of (c_Some * arguments) reg
|
| SomeApp of (c_Some * 'a arguments) reg
|
||||||
| MapLookUp of map_lookup reg
|
| MapLookUp of 'a map_lookup reg
|
||||||
| ParExpr of expr par
|
| ParExpr of 'a expr par
|
||||||
|
|
||||||
and tuple = (expr, comma) nsepseq par
|
and 'a tuple = ('a expr, comma) nsepseq par
|
||||||
|
|
||||||
and empty_list =
|
and 'a empty_list =
|
||||||
(lbracket * rbracket * colon * type_expr) par
|
(lbracket * rbracket * colon * 'a type_expr) par
|
||||||
|
|
||||||
and empty_set =
|
and 'a empty_set =
|
||||||
(lbrace * rbrace * colon * type_expr) par
|
(lbrace * rbrace * colon * 'a type_expr) par
|
||||||
|
|
||||||
and none_expr =
|
and 'a none_expr =
|
||||||
(c_None * colon * type_expr) par
|
(c_None * colon * 'a type_expr) par
|
||||||
|
|
||||||
and fun_call = (fun_name * arguments) reg
|
and 'a fun_call = ('a fun_name * 'a arguments) reg
|
||||||
|
|
||||||
and arguments = tuple
|
and 'a arguments = 'a tuple
|
||||||
|
|
||||||
and constr_app = (constr * arguments) reg
|
and 'a constr_app = ('a constr * 'a arguments) reg
|
||||||
|
|
||||||
and map_lookup = {
|
and 'a map_lookup = {
|
||||||
map_name : variable;
|
map_name : 'a variable;
|
||||||
selector : dot;
|
selector : dot;
|
||||||
index : expr brackets
|
index : 'a expr brackets
|
||||||
}
|
}
|
||||||
|
|
||||||
(* Patterns *)
|
(* Patterns *)
|
||||||
|
|
||||||
and pattern = (core_pattern, cons) nsepseq reg
|
and 'a pattern = ('a core_pattern, cons) nsepseq reg
|
||||||
|
|
||||||
and core_pattern =
|
and 'a core_pattern =
|
||||||
PVar of Lexer.lexeme reg
|
PVar of Lexer.lexeme reg
|
||||||
| PWild of wild
|
| PWild of wild
|
||||||
| PInt of (Lexer.lexeme * Z.t) reg
|
| PInt of (Lexer.lexeme * Z.t) reg
|
||||||
@ -405,26 +405,97 @@ and core_pattern =
|
|||||||
| PFalse of c_False
|
| PFalse of c_False
|
||||||
| PTrue of c_True
|
| PTrue of c_True
|
||||||
| PNone of c_None
|
| PNone of c_None
|
||||||
| PSome of (c_Some * core_pattern par) reg
|
| PSome of (c_Some * 'a core_pattern par) reg
|
||||||
| PList of list_pattern
|
| PList of 'a list_pattern
|
||||||
| PTuple of (core_pattern, comma) nsepseq par
|
| PTuple of ('a core_pattern, comma) nsepseq par
|
||||||
|
|
||||||
and list_pattern =
|
and 'a list_pattern =
|
||||||
Sugar of (core_pattern, comma) sepseq brackets
|
Sugar of ('a core_pattern, comma) sepseq brackets
|
||||||
| Raw of (core_pattern * cons * pattern) par
|
| Raw of ('a core_pattern * cons * 'a pattern) par
|
||||||
|
|
||||||
(* Projecting regions *)
|
(* Projecting regions *)
|
||||||
|
|
||||||
val type_expr_to_region : type_expr -> Region.t
|
val type_expr_to_region : 'a type_expr -> Region.t
|
||||||
|
|
||||||
val expr_to_region : expr -> Region.t
|
val expr_to_region : 'a expr -> Region.t
|
||||||
|
|
||||||
val instr_to_region : instruction -> Region.t
|
val instr_to_region : 'a instruction -> Region.t
|
||||||
|
|
||||||
val core_pattern_to_region : core_pattern -> Region.t
|
val core_pattern_to_region : 'a core_pattern -> Region.t
|
||||||
|
|
||||||
val local_decl_to_region : local_decl -> Region.t
|
val local_decl_to_region : 'a local_decl -> Region.t
|
||||||
|
|
||||||
(* Printing *)
|
type 'a visitor = {
|
||||||
|
ass_instr : 'a ass_instr -> unit;
|
||||||
val print_tokens : t -> unit
|
bind_to : (Region.t * 'a variable) option -> unit;
|
||||||
|
block : 'a block reg -> unit;
|
||||||
|
bytes : (string * MBytes.t) reg -> unit;
|
||||||
|
cartesian : 'a cartesian -> unit;
|
||||||
|
case : 'a case -> unit;
|
||||||
|
cases : 'a cases -> unit;
|
||||||
|
conditional : 'a conditional -> unit;
|
||||||
|
const_decl : 'a const_decl reg -> unit;
|
||||||
|
constr : 'a constr -> unit;
|
||||||
|
constr_app : 'a constr_app -> unit;
|
||||||
|
core_pattern : 'a core_pattern -> unit;
|
||||||
|
down : Region.t option -> unit;
|
||||||
|
empty_list : 'a empty_list -> unit;
|
||||||
|
empty_set : 'a empty_set -> unit;
|
||||||
|
expr : 'a expr -> unit;
|
||||||
|
fail : (kwd_fail * 'a expr) -> unit;
|
||||||
|
field_decl : 'a field_decl -> unit;
|
||||||
|
field_decls : 'a field_decls -> unit;
|
||||||
|
for_collect : 'a for_collect reg -> unit;
|
||||||
|
for_int : 'a for_int reg -> unit;
|
||||||
|
for_loop : 'a for_loop -> unit;
|
||||||
|
fun_call : 'a fun_call -> unit;
|
||||||
|
fun_decl : 'a fun_decl reg -> unit;
|
||||||
|
instruction : 'a instruction -> unit;
|
||||||
|
instructions : 'a instructions -> unit;
|
||||||
|
int : (string * Z.t) reg -> unit;
|
||||||
|
lambda_decl : 'a lambda_decl -> unit;
|
||||||
|
list : ('a expr, Region.t) nsepseq brackets -> unit;
|
||||||
|
list_pattern : 'a list_pattern -> unit;
|
||||||
|
loop : 'a loop -> unit;
|
||||||
|
map_lookup : 'a map_lookup reg -> unit;
|
||||||
|
match_instr : 'a match_instr -> unit;
|
||||||
|
none_expr : 'a none_expr -> unit;
|
||||||
|
nsepseq : 'a.string -> ('a -> unit) -> ('a, Region.t) nsepseq -> unit;
|
||||||
|
operations_decl : 'a operations_decl reg -> unit;
|
||||||
|
par_expr : 'a expr par -> unit;
|
||||||
|
par_type : 'a type_expr par -> unit;
|
||||||
|
param_decl : 'a param_decl -> unit;
|
||||||
|
parameter_decl : 'a parameter_decl reg -> unit;
|
||||||
|
parameters : 'a parameters -> unit;
|
||||||
|
param_const : 'a param_const -> unit;
|
||||||
|
param_var : 'a param_var -> unit;
|
||||||
|
pattern : 'a pattern -> unit;
|
||||||
|
patterns : 'a core_pattern par -> unit;
|
||||||
|
proc_decl : 'a proc_decl reg -> unit;
|
||||||
|
psome : (Region.t * 'a core_pattern par) reg -> unit;
|
||||||
|
ptuple : ('a core_pattern, Region.t) nsepseq par -> unit;
|
||||||
|
raw : ('a core_pattern * Region.t * 'a pattern) par -> unit;
|
||||||
|
record_type : 'a record_type -> unit;
|
||||||
|
sepseq : 'a.string -> ('a -> unit) -> ('a, Region.t) sepseq -> unit;
|
||||||
|
set : ('a expr, Region.t) nsepseq braces -> unit;
|
||||||
|
single_instr : 'a single_instr -> unit;
|
||||||
|
some_app : (Region.t * 'a arguments) reg -> unit;
|
||||||
|
step : (Region.t * 'a expr) option -> unit;
|
||||||
|
storage_decl : 'a storage_decl reg -> unit;
|
||||||
|
string : string reg -> unit;
|
||||||
|
sugar : ('a core_pattern, Region.t) sepseq brackets -> unit;
|
||||||
|
sum_type : ('a variant, Region.t) nsepseq reg -> unit;
|
||||||
|
terminator : semi option -> unit;
|
||||||
|
token : Region.t -> string -> unit;
|
||||||
|
tuple : 'a arguments -> unit;
|
||||||
|
type_app : ('a type_name * 'a type_tuple) reg -> unit;
|
||||||
|
type_decl : 'a type_decl reg -> unit;
|
||||||
|
type_expr : 'a type_expr -> unit;
|
||||||
|
type_tuple : 'a type_tuple -> unit;
|
||||||
|
local_decl : 'a local_decl -> unit;
|
||||||
|
local_decls : 'a local_decl list -> unit;
|
||||||
|
var : 'a variable -> unit;
|
||||||
|
var_decl : 'a var_decl reg -> unit;
|
||||||
|
variant : 'a variant -> unit;
|
||||||
|
while_loop : 'a while_loop -> unit
|
||||||
|
}
|
||||||
|
|||||||
@ -58,7 +58,7 @@ let () =
|
|||||||
try
|
try
|
||||||
let ast = Parser.program tokeniser buffer in
|
let ast = Parser.program tokeniser buffer in
|
||||||
if Utils.String.Set.mem "parser" EvalOpt.verbose
|
if Utils.String.Set.mem "parser" EvalOpt.verbose
|
||||||
then AST.print_tokens ast
|
then Print.print_tokens ast
|
||||||
with
|
with
|
||||||
Lexer.Error err ->
|
Lexer.Error err ->
|
||||||
close_all ();
|
close_all ();
|
||||||
|
|||||||
573
Print.ml
Normal file
573
Print.ml
Normal file
@ -0,0 +1,573 @@
|
|||||||
|
open AST
|
||||||
|
open Utils
|
||||||
|
open Region
|
||||||
|
|
||||||
|
let printf = Printf.printf
|
||||||
|
|
||||||
|
let compact (region: Region.t) =
|
||||||
|
region#compact ~offsets:EvalOpt.offsets EvalOpt.mode
|
||||||
|
|
||||||
|
let print_nsepseq :
|
||||||
|
string -> ('a -> unit) -> ('a, Region.t) nsepseq -> unit =
|
||||||
|
fun sep visit (head, tail) ->
|
||||||
|
let print_aux (sep_reg, item) =
|
||||||
|
printf "%s: %s\n" (compact sep_reg) sep;
|
||||||
|
visit item
|
||||||
|
in visit head; List.iter print_aux tail
|
||||||
|
|
||||||
|
let print_sepseq :
|
||||||
|
string -> ('a -> unit) -> ('a, Region.t) sepseq -> unit =
|
||||||
|
fun sep visit -> function
|
||||||
|
None -> ()
|
||||||
|
| Some seq -> print_nsepseq sep visit seq
|
||||||
|
|
||||||
|
and print_token _visitor region lexeme =
|
||||||
|
printf "%s: %s\n"(compact region) lexeme
|
||||||
|
|
||||||
|
and print_var _visitor {region; value=lexeme} =
|
||||||
|
printf "%s: Ident \"%s\"\n" (compact region) lexeme
|
||||||
|
|
||||||
|
and print_constr _visitor {region; value=lexeme} =
|
||||||
|
printf "%s: Constr \"%s\"\n"
|
||||||
|
(compact region) lexeme
|
||||||
|
|
||||||
|
and print_string _visitor {region; value=lexeme} =
|
||||||
|
printf "%s: String \"%s\"\n"
|
||||||
|
(compact region) lexeme
|
||||||
|
|
||||||
|
and print_bytes _visitor {region; value = lexeme, abstract} =
|
||||||
|
printf "%s: Bytes (\"%s\", \"0x%s\")\n"
|
||||||
|
(compact region) lexeme
|
||||||
|
(MBytes.to_hex abstract |> Hex.to_string)
|
||||||
|
|
||||||
|
and print_int _visitor {region; value = lexeme, abstract} =
|
||||||
|
printf "%s: Int (\"%s\", %s)\n"
|
||||||
|
(compact region) lexeme
|
||||||
|
(Z.to_string abstract)
|
||||||
|
|
||||||
|
(* Main printing function *)
|
||||||
|
|
||||||
|
and print_tokens (v: 'a visitor) ast =
|
||||||
|
List.iter v.type_decl ast.types;
|
||||||
|
v.parameter_decl ast.parameter;
|
||||||
|
v.storage_decl ast.storage;
|
||||||
|
v.operations_decl ast.operations;
|
||||||
|
List.iter v.lambda_decl ast.lambdas;
|
||||||
|
v.block ast.block;
|
||||||
|
v.token ast.eof "EOF"
|
||||||
|
|
||||||
|
and print_parameter_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_parameter "parameter";
|
||||||
|
v.var node.name;
|
||||||
|
v.token node.colon ":";
|
||||||
|
v.type_expr node.param_type;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_storage_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_storage "storage";
|
||||||
|
v.type_expr node.store_type;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_operations_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_operations "operations";
|
||||||
|
v.type_expr node.op_type;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_type_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_type "type";
|
||||||
|
v.var node.name;
|
||||||
|
v.token node.kwd_is "is";
|
||||||
|
v.type_expr node.type_expr;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_type_expr (v: 'a visitor) = function
|
||||||
|
Prod cartesian -> v.cartesian cartesian
|
||||||
|
| Sum sum_type -> v.sum_type sum_type
|
||||||
|
| Record record_type -> v.record_type record_type
|
||||||
|
| TypeApp type_app -> v.type_app type_app
|
||||||
|
| ParType par_type -> v.par_type par_type
|
||||||
|
| TAlias type_alias -> v.var type_alias
|
||||||
|
|
||||||
|
and print_cartesian (v: 'a visitor) {value=sequence; _} =
|
||||||
|
v.nsepseq "*" v.type_expr sequence
|
||||||
|
|
||||||
|
and print_variant (v: 'a visitor) {value=node; _} =
|
||||||
|
let constr, kwd_of, cartesian = node in
|
||||||
|
v.constr constr;
|
||||||
|
v.token kwd_of "of";
|
||||||
|
v.cartesian cartesian
|
||||||
|
|
||||||
|
and print_sum_type (v: 'a visitor) {value=sequence; _} =
|
||||||
|
v.nsepseq "|" v.variant sequence
|
||||||
|
|
||||||
|
and print_record_type (v: 'a visitor) {value=node; _} =
|
||||||
|
let kwd_record, field_decls, kwd_end = node in
|
||||||
|
v.token kwd_record "record";
|
||||||
|
v.field_decls field_decls;
|
||||||
|
v.token kwd_end "end"
|
||||||
|
|
||||||
|
and print_type_app (v: 'a visitor) {value=node; _} =
|
||||||
|
let type_name, type_tuple = node in
|
||||||
|
v.var type_name;
|
||||||
|
v.type_tuple type_tuple
|
||||||
|
|
||||||
|
and print_par_type (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, type_expr, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.type_expr type_expr;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_field_decls (v: 'a visitor) sequence =
|
||||||
|
v.nsepseq ";" v.field_decl sequence
|
||||||
|
|
||||||
|
and print_field_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
let var, colon, type_expr = node in
|
||||||
|
v.var var;
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr
|
||||||
|
|
||||||
|
and print_type_tuple (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, sequence, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.nsepseq "," v.var sequence;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_lambda_decl (v: 'a visitor) = function
|
||||||
|
FunDecl fun_decl -> v.fun_decl fun_decl
|
||||||
|
| ProcDecl proc_decl -> v.proc_decl proc_decl
|
||||||
|
|
||||||
|
and print_fun_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_function "function";
|
||||||
|
v.var node.name;
|
||||||
|
v.parameters node.param;
|
||||||
|
v.token node.colon ":";
|
||||||
|
v.type_expr node.ret_type;
|
||||||
|
v.token node.kwd_is "is";
|
||||||
|
v.local_decls node.local_decls;
|
||||||
|
v.block node.block;
|
||||||
|
v.token node.kwd_with "with";
|
||||||
|
v.expr node.return;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_proc_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_procedure "procedure";
|
||||||
|
v.var node.name;
|
||||||
|
v.parameters node.param;
|
||||||
|
v.token node.kwd_is "is";
|
||||||
|
v.local_decls node.local_decls;
|
||||||
|
v.block node.block;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_parameters (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, sequence, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.nsepseq ";" v.param_decl sequence;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_param_decl (v: 'a visitor) = function
|
||||||
|
ParamConst param_const -> v.param_const param_const
|
||||||
|
| ParamVar param_var -> v.param_var param_var
|
||||||
|
|
||||||
|
and print_param_const (v: 'a visitor) {value=node; _} =
|
||||||
|
let kwd_const, variable, colon, type_expr = node in
|
||||||
|
v.token kwd_const "const";
|
||||||
|
v.var variable;
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr
|
||||||
|
|
||||||
|
and print_param_var (v: 'a visitor) {value=node; _} =
|
||||||
|
let kwd_var, variable, colon, type_expr = node in
|
||||||
|
v.token kwd_var "var";
|
||||||
|
v.var variable;
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr
|
||||||
|
|
||||||
|
and print_block (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.opening "begin";
|
||||||
|
v.instructions node.instr;
|
||||||
|
v.terminator node.terminator;
|
||||||
|
v.token node.close "end"
|
||||||
|
|
||||||
|
and print_local_decls (v: 'a visitor) sequence =
|
||||||
|
List.iter v.local_decl sequence
|
||||||
|
|
||||||
|
and print_local_decl (v: 'a visitor) = function
|
||||||
|
LocalLam decl -> v.lambda_decl decl
|
||||||
|
| LocalConst decl -> v.const_decl decl
|
||||||
|
| LocalVar decl -> v.var_decl decl
|
||||||
|
|
||||||
|
and print_const_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_const "const";
|
||||||
|
v.var node.name;
|
||||||
|
v.token node.colon ":";
|
||||||
|
v.type_expr node.vtype;
|
||||||
|
v.token node.equal "=";
|
||||||
|
v.expr node.init;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_var_decl (v: 'a visitor) {value=node; _} =
|
||||||
|
v.token node.kwd_var "var";
|
||||||
|
v.var node.name;
|
||||||
|
v.token node.colon ":";
|
||||||
|
v.type_expr node.vtype;
|
||||||
|
v.token node.ass ":=";
|
||||||
|
v.expr node.init;
|
||||||
|
v.terminator node.terminator
|
||||||
|
|
||||||
|
and print_instructions (v: 'a visitor) {value=sequence; _} =
|
||||||
|
v.nsepseq ";" v.instruction sequence
|
||||||
|
|
||||||
|
and print_instruction (v: 'a visitor) = function
|
||||||
|
Single instr -> v.single_instr instr
|
||||||
|
| Block block -> v.block block
|
||||||
|
|
||||||
|
and print_single_instr (v: 'a visitor) = function
|
||||||
|
Cond {value; _} -> v.conditional value
|
||||||
|
| Match {value; _} -> v.match_instr value
|
||||||
|
| Ass instr -> v.ass_instr instr
|
||||||
|
| Loop loop -> v.loop loop
|
||||||
|
| ProcCall fun_call -> v.fun_call fun_call
|
||||||
|
| Null kwd_null -> v.token kwd_null "null"
|
||||||
|
| Fail {value; _} -> v.fail value
|
||||||
|
|
||||||
|
and print_fail (v: 'a visitor) (kwd_fail, expr) =
|
||||||
|
v.token kwd_fail "fail";
|
||||||
|
v.expr expr
|
||||||
|
|
||||||
|
and print_conditional (v: 'a visitor) node =
|
||||||
|
v.token node.kwd_if "if";
|
||||||
|
v.expr node.test;
|
||||||
|
v.token node.kwd_then "then";
|
||||||
|
v.instruction node.ifso;
|
||||||
|
v.token node.kwd_else "else";
|
||||||
|
v.instruction node.ifnot
|
||||||
|
|
||||||
|
and print_match_instr (v: 'a visitor) node =
|
||||||
|
v.token node.kwd_match "match";
|
||||||
|
v.expr node.expr;
|
||||||
|
v.token node.kwd_with "with";
|
||||||
|
v.cases node.cases;
|
||||||
|
v.token node.kwd_end "end"
|
||||||
|
|
||||||
|
and print_cases (v: 'a visitor) {value=sequence; _} =
|
||||||
|
v.nsepseq "|" v.case sequence
|
||||||
|
|
||||||
|
and print_case (v: 'a visitor) {value=node; _} =
|
||||||
|
let pattern, arrow, instruction = node in
|
||||||
|
v.pattern pattern;
|
||||||
|
v.token arrow "->";
|
||||||
|
v.instruction instruction
|
||||||
|
|
||||||
|
and print_ass_instr (v: 'a visitor) {value=node; _} =
|
||||||
|
let variable, ass, expr = node in
|
||||||
|
v.var variable;
|
||||||
|
v.token ass ":=";
|
||||||
|
v.expr expr
|
||||||
|
|
||||||
|
and print_loop (v: 'a visitor) = function
|
||||||
|
While while_loop -> v.while_loop while_loop
|
||||||
|
| For for_loop -> v.for_loop for_loop
|
||||||
|
|
||||||
|
and print_while_loop (v: 'a visitor) {value=node; _} =
|
||||||
|
let kwd_while, expr, block = node in
|
||||||
|
v.token kwd_while "while";
|
||||||
|
v.expr expr;
|
||||||
|
v.block block
|
||||||
|
|
||||||
|
and print_for_loop (v: 'a visitor) = function
|
||||||
|
ForInt for_int -> v.for_int for_int
|
||||||
|
| ForCollect for_collect -> v.for_collect for_collect
|
||||||
|
|
||||||
|
and print_for_int (v: 'a visitor) ({value=node; _} : 'a for_int reg) =
|
||||||
|
v.token node.kwd_for "for";
|
||||||
|
v.ass_instr node.ass;
|
||||||
|
v.down node.down;
|
||||||
|
v.token node.kwd_to "to";
|
||||||
|
v.expr node.bound;
|
||||||
|
v.step node.step;
|
||||||
|
v.block node.block
|
||||||
|
|
||||||
|
and print_down (v: 'a visitor) = function
|
||||||
|
Some kwd_down -> v.token kwd_down "down"
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
|
and print_step (v: 'a visitor) = function
|
||||||
|
Some (kwd_step, expr) ->
|
||||||
|
v.token kwd_step "step";
|
||||||
|
v.expr expr
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
|
and print_for_collect (v: 'a visitor) ({value=node; _} : 'a for_collect reg) =
|
||||||
|
v.token node.kwd_for "for";
|
||||||
|
v.var node.var;
|
||||||
|
v.bind_to node.bind_to;
|
||||||
|
v.token node.kwd_in "in";
|
||||||
|
v.expr node.expr;
|
||||||
|
v.block node.block
|
||||||
|
|
||||||
|
and print_bind_to (v: 'a visitor) = function
|
||||||
|
Some (arrow, variable) ->
|
||||||
|
v.token arrow "->";
|
||||||
|
v.var variable
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
|
and print_expr (v: 'a visitor) = function
|
||||||
|
Or {value = expr1, bool_or, expr2; _} ->
|
||||||
|
v.expr expr1; v.token bool_or "||"; v.expr expr2
|
||||||
|
| And {value = expr1, bool_and, expr2; _} ->
|
||||||
|
v.expr expr1; v.token bool_and "&&"; v.expr expr2
|
||||||
|
| Lt {value = expr1, lt, expr2; _} ->
|
||||||
|
v.expr expr1; v.token lt "<"; v.expr expr2
|
||||||
|
| Leq {value = expr1, leq, expr2; _} ->
|
||||||
|
v.expr expr1; v.token leq "<="; v.expr expr2
|
||||||
|
| Gt {value = expr1, gt, expr2; _} ->
|
||||||
|
v.expr expr1; v.token gt ">"; v.expr expr2
|
||||||
|
| Geq {value = expr1, geq, expr2; _} ->
|
||||||
|
v.expr expr1; v.token geq ">="; v.expr expr2
|
||||||
|
| Equal {value = expr1, equal, expr2; _} ->
|
||||||
|
v.expr expr1; v.token equal "="; v.expr expr2
|
||||||
|
| Neq {value = expr1, neq, expr2; _} ->
|
||||||
|
v.expr expr1; v.token neq "=/="; v.expr expr2
|
||||||
|
| Cat {value = expr1, cat, expr2; _} ->
|
||||||
|
v.expr expr1; v.token cat "^"; v.expr expr2
|
||||||
|
| Cons {value = expr1, cons, expr2; _} ->
|
||||||
|
v.expr expr1; v.token cons "<:"; v.expr expr2
|
||||||
|
| Add {value = expr1, add, expr2; _} ->
|
||||||
|
v.expr expr1; v.token add "+"; v.expr expr2
|
||||||
|
| Sub {value = expr1, sub, expr2; _} ->
|
||||||
|
v.expr expr1; v.token sub "-"; v.expr expr2
|
||||||
|
| Mult {value = expr1, mult, expr2; _} ->
|
||||||
|
v.expr expr1; v.token mult "*"; v.expr expr2
|
||||||
|
| Div {value = expr1, div, expr2; _} ->
|
||||||
|
v.expr expr1; v.token div "/"; v.expr expr2
|
||||||
|
| Mod {value = expr1, kwd_mod, expr2; _} ->
|
||||||
|
v.expr expr1; v.token kwd_mod "mod"; v.expr expr2
|
||||||
|
| Neg {value = minus, expr; _} ->
|
||||||
|
v.token minus "-"; v.expr expr
|
||||||
|
| Not {value = kwd_not, expr; _} ->
|
||||||
|
v.token kwd_not "not"; v.expr expr
|
||||||
|
| Int i -> v.int i
|
||||||
|
| Var var -> v.var var
|
||||||
|
| String s -> v.string s
|
||||||
|
| Bytes b -> v.bytes b
|
||||||
|
| False region -> v.token region "False"
|
||||||
|
| True region -> v.token region "True"
|
||||||
|
| Unit region -> v.token region "Unit"
|
||||||
|
| Tuple tuple -> v.tuple tuple
|
||||||
|
| List list -> v.list list
|
||||||
|
| EmptyList elist -> v.empty_list elist
|
||||||
|
| Set set -> v.set set
|
||||||
|
| EmptySet eset -> v.empty_set eset
|
||||||
|
| NoneExpr nexpr -> v.none_expr nexpr
|
||||||
|
| FunCall fun_call -> v.fun_call fun_call
|
||||||
|
| ConstrApp capp -> v.constr_app capp
|
||||||
|
| SomeApp sapp -> v.some_app sapp
|
||||||
|
| MapLookUp lookup -> v.map_lookup lookup
|
||||||
|
| ParExpr pexpr -> v.par_expr pexpr
|
||||||
|
|
||||||
|
and print_tuple (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, sequence, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.nsepseq "," v.expr sequence;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_list (v: 'a visitor) {value=node; _} =
|
||||||
|
let lbra, sequence, rbra = node in
|
||||||
|
v.token lbra "[";
|
||||||
|
v.nsepseq "," v.expr sequence;
|
||||||
|
v.token rbra "]"
|
||||||
|
|
||||||
|
and print_empty_list (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.token lbracket "[";
|
||||||
|
v.token rbracket "]";
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_set (v: 'a visitor) {value=node; _} =
|
||||||
|
let lbrace, sequence, rbrace = node in
|
||||||
|
v.token lbrace "{";
|
||||||
|
v.nsepseq "," v.expr sequence;
|
||||||
|
v.token rbrace "}"
|
||||||
|
|
||||||
|
and print_empty_set (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.token lbrace "{";
|
||||||
|
v.token rbrace "}";
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_none_expr (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, (c_None, colon, type_expr), rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.token c_None "None";
|
||||||
|
v.token colon ":";
|
||||||
|
v.type_expr type_expr;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_fun_call (v: 'a visitor) {value=node; _} =
|
||||||
|
let fun_name, arguments = node in
|
||||||
|
v.var fun_name;
|
||||||
|
v.tuple arguments
|
||||||
|
|
||||||
|
and print_constr_app (v: 'a visitor) {value=node; _} =
|
||||||
|
let constr, arguments = node in
|
||||||
|
v.constr constr;
|
||||||
|
v.tuple arguments
|
||||||
|
|
||||||
|
and print_some_app (v: 'a visitor) {value=node; _} =
|
||||||
|
let c_Some, arguments = node in
|
||||||
|
v.token c_Some "Some";
|
||||||
|
v.tuple arguments
|
||||||
|
|
||||||
|
and print_map_lookup (v: 'a visitor) {value=node; _} =
|
||||||
|
let {value = lbracket, expr, rbracket; _} = node.index in
|
||||||
|
v.var node.map_name;
|
||||||
|
v.token node.selector ".";
|
||||||
|
v.token lbracket "[";
|
||||||
|
v.expr expr;
|
||||||
|
v.token rbracket "]"
|
||||||
|
|
||||||
|
and print_par_expr (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, expr, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.expr expr;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_pattern (v: 'a visitor) {value=sequence; _} =
|
||||||
|
v.nsepseq "<:" v.core_pattern sequence
|
||||||
|
|
||||||
|
and print_core_pattern (v: 'a visitor) = function
|
||||||
|
PVar var -> v.var var
|
||||||
|
| PWild wild -> v.token wild "_"
|
||||||
|
| PInt i -> v.int i
|
||||||
|
| PBytes b -> v.bytes b
|
||||||
|
| PString s -> v.string s
|
||||||
|
| PUnit region -> v.token region "Unit"
|
||||||
|
| PFalse region -> v.token region "False"
|
||||||
|
| PTrue region -> v.token region "True"
|
||||||
|
| PNone region -> v.token region "None"
|
||||||
|
| PSome psome -> v.psome psome
|
||||||
|
| PList pattern -> v.list_pattern pattern
|
||||||
|
| PTuple ptuple -> v.ptuple ptuple
|
||||||
|
|
||||||
|
and print_psome (v: 'a visitor) {value=node; _} =
|
||||||
|
let c_Some, patterns = node in
|
||||||
|
v.token c_Some "Some";
|
||||||
|
v.patterns patterns
|
||||||
|
|
||||||
|
and print_patterns (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, core_pattern, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.core_pattern core_pattern;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_list_pattern (v: 'a visitor) = function
|
||||||
|
Sugar sugar -> v.sugar sugar
|
||||||
|
| Raw raw -> v.raw raw
|
||||||
|
|
||||||
|
and print_sugar (v: 'a visitor) {value=node; _} =
|
||||||
|
let lbracket, sequence, rbracket = node in
|
||||||
|
v.token lbracket "[";
|
||||||
|
v.sepseq "," v.core_pattern sequence;
|
||||||
|
v.token rbracket "]"
|
||||||
|
|
||||||
|
and print_raw (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, (core_pattern, cons, pattern), rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.core_pattern core_pattern;
|
||||||
|
v.token cons "<:";
|
||||||
|
v.pattern pattern;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_ptuple (v: 'a visitor) {value=node; _} =
|
||||||
|
let lpar, sequence, rpar = node in
|
||||||
|
v.token lpar "(";
|
||||||
|
v.nsepseq "," v.core_pattern sequence;
|
||||||
|
v.token rpar ")"
|
||||||
|
|
||||||
|
and print_terminator (v: 'a visitor) = function
|
||||||
|
Some semi -> v.token semi ";"
|
||||||
|
| None -> ()
|
||||||
|
|
||||||
|
let rec visitor () : 'a visitor = {
|
||||||
|
nsepseq = print_nsepseq;
|
||||||
|
sepseq = print_sepseq;
|
||||||
|
token = print_token (visitor ());
|
||||||
|
var = print_var (visitor ());
|
||||||
|
constr = print_constr (visitor ());
|
||||||
|
string = print_string (visitor ());
|
||||||
|
bytes = print_bytes (visitor ());
|
||||||
|
int = print_int (visitor ());
|
||||||
|
|
||||||
|
local_decl = print_local_decl (visitor ());
|
||||||
|
fail = print_fail (visitor ());
|
||||||
|
param_var = print_param_var (visitor ());
|
||||||
|
param_const = print_param_const (visitor ());
|
||||||
|
const_decl = print_const_decl (visitor ());
|
||||||
|
parameter_decl = print_parameter_decl (visitor ());
|
||||||
|
storage_decl = print_storage_decl (visitor ());
|
||||||
|
operations_decl = print_operations_decl (visitor ());
|
||||||
|
type_decl = print_type_decl (visitor ());
|
||||||
|
type_expr = print_type_expr (visitor ());
|
||||||
|
cartesian = print_cartesian (visitor ());
|
||||||
|
variant = print_variant (visitor ());
|
||||||
|
sum_type = print_sum_type (visitor ());
|
||||||
|
record_type = print_record_type (visitor ());
|
||||||
|
type_app = print_type_app (visitor ());
|
||||||
|
par_type = print_par_type (visitor ());
|
||||||
|
field_decls = print_field_decls (visitor ());
|
||||||
|
field_decl = print_field_decl (visitor ());
|
||||||
|
type_tuple = print_type_tuple (visitor ());
|
||||||
|
lambda_decl = print_lambda_decl (visitor ());
|
||||||
|
fun_decl = print_fun_decl (visitor ());
|
||||||
|
proc_decl = print_proc_decl (visitor ());
|
||||||
|
parameters = print_parameters (visitor ());
|
||||||
|
param_decl = print_param_decl (visitor ());
|
||||||
|
block = print_block (visitor ());
|
||||||
|
local_decls = print_local_decls (visitor ());
|
||||||
|
var_decl = print_var_decl (visitor ());
|
||||||
|
instructions = print_instructions (visitor ());
|
||||||
|
instruction = print_instruction (visitor ());
|
||||||
|
single_instr = print_single_instr (visitor ());
|
||||||
|
conditional = print_conditional (visitor ());
|
||||||
|
match_instr = print_match_instr (visitor ());
|
||||||
|
cases = print_cases (visitor ());
|
||||||
|
case = print_case (visitor ());
|
||||||
|
ass_instr = print_ass_instr (visitor ());
|
||||||
|
loop = print_loop (visitor ());
|
||||||
|
while_loop = print_while_loop (visitor ());
|
||||||
|
for_loop = print_for_loop (visitor ());
|
||||||
|
for_int = print_for_int (visitor ());
|
||||||
|
down = print_down (visitor ());
|
||||||
|
step = print_step (visitor ());
|
||||||
|
for_collect = print_for_collect (visitor ());
|
||||||
|
bind_to = print_bind_to (visitor ());
|
||||||
|
expr = print_expr (visitor ());
|
||||||
|
tuple = print_tuple (visitor ());
|
||||||
|
list = print_list (visitor ());
|
||||||
|
empty_list = print_empty_list (visitor ());
|
||||||
|
set = print_set (visitor ());
|
||||||
|
empty_set = print_empty_set (visitor ());
|
||||||
|
none_expr = print_none_expr (visitor ());
|
||||||
|
fun_call = print_fun_call (visitor ());
|
||||||
|
constr_app = print_constr_app (visitor ());
|
||||||
|
some_app = print_some_app (visitor ());
|
||||||
|
map_lookup = print_map_lookup (visitor ());
|
||||||
|
par_expr = print_par_expr (visitor ());
|
||||||
|
pattern = print_pattern (visitor ());
|
||||||
|
core_pattern = print_core_pattern (visitor ());
|
||||||
|
psome = print_psome (visitor ());
|
||||||
|
patterns = print_patterns (visitor ());
|
||||||
|
list_pattern = print_list_pattern (visitor ());
|
||||||
|
sugar = print_sugar (visitor ());
|
||||||
|
raw = print_raw (visitor ());
|
||||||
|
ptuple = print_ptuple (visitor ());
|
||||||
|
terminator = print_terminator (visitor ())
|
||||||
|
}
|
||||||
|
|
||||||
|
let print_tokens = print_tokens (visitor ())
|
||||||
5
Print.mli
Normal file
5
Print.mli
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
(* Printing *)
|
||||||
|
|
||||||
|
open AST
|
||||||
|
|
||||||
|
val print_tokens : t -> unit
|
||||||
112
typecheck.ml
112
typecheck.ml
@ -1,3 +1,9 @@
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(*
|
||||||
module I = AST (* In *)
|
module I = AST (* In *)
|
||||||
|
|
||||||
module SMap = Map.Make(String)
|
module SMap = Map.Make(String)
|
||||||
@ -35,27 +41,28 @@ module O = struct
|
|||||||
| ProcDecl of proc_decl
|
| ProcDecl of proc_decl
|
||||||
|
|
||||||
and fun_decl = {
|
and fun_decl = {
|
||||||
|
local_decls : local_decls;
|
||||||
kwd_function : kwd_function;
|
kwd_function : kwd_function;
|
||||||
var : variable;
|
name : variable;
|
||||||
param : parameters;
|
param : parameters;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
ret_type : type_expr;
|
ret_type : type_expr;
|
||||||
kwd_is : kwd_is;
|
kwd_is : kwd_is;
|
||||||
body : block;
|
body : block;
|
||||||
kwd_with : kwd_with;
|
kwd_with : kwd_with;
|
||||||
return : checked_expr
|
return : expr
|
||||||
}
|
}
|
||||||
|
|
||||||
and proc_decl = {
|
and proc_decl = {
|
||||||
kwd_procedure : kwd_procedure;
|
kwd_procedure : kwd_procedure;
|
||||||
var : variable;
|
name : variable;
|
||||||
param : parameters;
|
param : parameters;
|
||||||
kwd_is : kwd_is;
|
kwd_is : kwd_is;
|
||||||
body : block
|
local_decls : local_decl list;
|
||||||
|
block : block reg
|
||||||
}
|
}
|
||||||
|
|
||||||
and block = {
|
and block = {
|
||||||
decls : value_decls;
|
|
||||||
opening : kwd_begin;
|
opening : kwd_begin;
|
||||||
instr : instructions;
|
instr : instructions;
|
||||||
close : kwd_end
|
close : kwd_end
|
||||||
@ -64,28 +71,21 @@ module O = struct
|
|||||||
and value_decls = var_decl list
|
and value_decls = var_decl list
|
||||||
|
|
||||||
and var_decl = {
|
and var_decl = {
|
||||||
kind : var_kind;
|
kwd_var : kwd_var;
|
||||||
var : variable;
|
name : variable;
|
||||||
colon : colon;
|
colon : colon;
|
||||||
vtype : type_expr;
|
vtype : type_expr;
|
||||||
setter : Region.t; (* "=" or ":=" *)
|
asgnmnt : Region.t; (* "=" or ":=" *)
|
||||||
init : checked_expr
|
init : expr
|
||||||
}
|
}
|
||||||
|
|
||||||
and checked_expr = {ty:type_expr;expr:expr}
|
and expr = {ty:type_expr;expr:expr}
|
||||||
end [@warning "-30"]
|
end [@warning "-30"]
|
||||||
|
|
||||||
open O
|
open O
|
||||||
open AST
|
open AST
|
||||||
open Region
|
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}
|
|
||||||
|
|
||||||
(* open Sanity: *)
|
(* open Sanity: *)
|
||||||
let (|>) v f = f v (* pipe f to v *)
|
let (|>) v f = f v (* pipe f to v *)
|
||||||
let (@@) f v = f v (* apply f on v *)
|
let (@@) f v = f v (* apply f on v *)
|
||||||
@ -130,16 +130,20 @@ let type_decls_to_tenv (td : I.type_decl list) (te : te) : O.te =
|
|||||||
|> List.map (fun (_, name, _, type_expr) -> (unreg name, xty type_expr))
|
|> List.map (fun (_, name, _, type_expr) -> (unreg name, xty type_expr))
|
||||||
|> fun up -> shadow_list up te
|
|> fun up -> shadow_list up te
|
||||||
|
|
||||||
let var_kind_to_ty : var_kind -> I.type_expr -> O.type_expr =
|
let param_const_to_xty : 'todo -> O.type_expr = function
|
||||||
fun var_kind ty ->
|
(_kwd_const, _variable, _colon, type_expr) -> O.Mutable (xty type_expr)
|
||||||
match var_kind with
|
|
||||||
Mutable _ -> O.Mutable (xty ty)
|
|
||||||
| Const _ -> xty ty
|
|
||||||
|
|
||||||
let params_to_xty params ret_type =
|
let param_var_to_xty : 'todo -> O.type_expr = function
|
||||||
|
(_kwd_var, _variable, _colon, type_expr) -> xty type_expr
|
||||||
|
|
||||||
|
let param_decl_to_xty : I.param_decl -> 'todo2 = function
|
||||||
|
ParamConst pc -> pc |> unreg |> param_const_to_xty
|
||||||
|
| ParamVar pv -> pv |> unreg |> param_var_to_xty
|
||||||
|
|
||||||
|
let params_to_xty (params : I.parameters) ret_type =
|
||||||
unpar params
|
unpar params
|
||||||
|> nsepseq_to_list
|
|> nsepseq_to_list
|
||||||
|> map (fun {value=(var_kind, _variable, _colon, type_expr);_} -> var_kind_to_ty var_kind type_expr)
|
|> map param_decl_to_xty
|
||||||
|> fun param_types -> O.Function (param_types, ret_type)
|
|> fun param_types -> O.Function (param_types, ret_type)
|
||||||
|
|
||||||
let type_equal t1 t2 = match t1,t2 with
|
let type_equal t1 t2 = match t1,t2 with
|
||||||
@ -153,37 +157,29 @@ let check_type expr expected_type =
|
|||||||
if type_equal expr.ty expected_type then expr
|
if type_equal expr.ty expected_type then expr
|
||||||
else raise (TypeError "oops")
|
else raise (TypeError "oops")
|
||||||
|
|
||||||
let tc_expr (_te,_ve) expr = mk_checked_expr ~ty:(TODO "all expressions") ~expr (* TODO *)
|
let tc_expr (_te,_ve) (expr : I.expr) (expected:O.type_expr) : O.expr = {ty=(TODO "all expressions");expr} (* TODO *)
|
||||||
|
|
||||||
let tc_var_decl : vte -> I.var_decl -> vte * O.var_decl =
|
let tc_var_decl : vte -> I.var_decl -> vte * O.var_decl =
|
||||||
fun (ve,te) var_decl ->
|
fun (ve,te) {kwd_var;name;colon;vtype;asgnmnt;init} ->
|
||||||
let vtype = (xty var_decl.vtype) in
|
let vtype = (xty vtype) in
|
||||||
let init = check_type (tc_expr (te,ve) var_decl.init) vtype in
|
let init = tc_expr (ve,te) init vtype in
|
||||||
let ve = shadow (unreg var_decl.var) vtype ve in
|
let ve,te = shadow (unreg name) vtype ve, te in
|
||||||
(ve,te), {
|
(ve,te), {kwd_var;name;colon;vtype;asgnmnt;init}
|
||||||
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_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 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 opening,instr,close = 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.{opening;instr;close} (* TODO *)
|
||||||
(ve,te), O.{decls;opening;instr;close} (* TODO *)
|
|
||||||
|
|
||||||
let tc_proc_decl : vte -> I.proc_decl -> O.proc_decl =
|
let tc_local_decl : I.local_decl -> 'todo =
|
||||||
fun vte proc_decl ->
|
`TODO
|
||||||
let _vte', block' = tc_block vte (unreg proc_decl.body)
|
|
||||||
in mk_proc_decl
|
let tc_proc_decl : vte -> I.proc_decl -> vte*O.proc_decl =
|
||||||
~kwd_procedure: proc_decl.kwd_procedure
|
fun vte {kwd_procedure;name;param;kwd_is;local_decls;block} ->
|
||||||
~kwd_is: proc_decl.kwd_is
|
let vte, local_decls = tc_var_decls vte (local_decls |> map tc_local_decl) in
|
||||||
~var: proc_decl.var
|
let vte, block = tc_block vte (unreg block)
|
||||||
~param: proc_decl.param
|
in vte,{kwd_procedure;name;param;kwd_is;local_decls;block}
|
||||||
~body: block'
|
|
||||||
|
|
||||||
let tc_fun_decl : vte -> I.fun_decl -> O.fun_decl =
|
let tc_fun_decl : vte -> I.fun_decl -> O.fun_decl =
|
||||||
fun vte fun_decl ->
|
fun vte fun_decl ->
|
||||||
@ -204,27 +200,29 @@ let tc_fun_decl : vte -> I.fun_decl -> O.fun_decl =
|
|||||||
let ve_lambda_decl : vte -> I.lambda_decl -> ve =
|
let ve_lambda_decl : vte -> I.lambda_decl -> ve =
|
||||||
fun (ve,_te) ->
|
fun (ve,_te) ->
|
||||||
function
|
function
|
||||||
FunDecl {value;_} -> shadow value.var.value (params_to_xty value.param (xty value.ret_type)) ve
|
FunDecl {value;_} -> shadow value.name.value (params_to_xty value.param (xty value.ret_type)) ve
|
||||||
| ProcDecl {value;_} -> shadow value.var.value (params_to_xty value.param Unit) ve
|
| ProcDecl {value;_} -> shadow value.name.value (params_to_xty value.param Unit) ve
|
||||||
|
|
||||||
let tc_lambda_decl (ve, te : vte) (whole : I.lambda_decl) : vte * O.lambda_decl =
|
let tc_lambda_decl (ve, te : vte) (whole : I.lambda_decl) : vte * O.lambda_decl =
|
||||||
match whole with
|
match whole with
|
||||||
FunDecl {value;_} -> ((ve_lambda_decl (ve, te) whole), te), O.FunDecl (tc_fun_decl (ve, te) value)
|
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)
|
| 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 =
|
let tc_ast : I.ast -> O.ast = fun
|
||||||
|
{types;constants;parameter;storage;operations;lambdas;block;eof} ->
|
||||||
(* te is the type environment, ve is the variable environment *)
|
(* te is the type environment, ve is the variable environment *)
|
||||||
let te =
|
let te =
|
||||||
SMap.empty
|
SMap.empty
|
||||||
|> type_decls_to_tenv ast.types in
|
|> type_decls_to_tenv types in
|
||||||
let ve =
|
let ve =
|
||||||
SMap.empty
|
SMap.empty
|
||||||
|> (match ast.parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty)
|
|> (match parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty)
|
||||||
|> shadow "storage" @@ xty (snd ast.storage.value)
|
|> shadow "storage" @@ xty (snd storage.value)
|
||||||
|> shadow "operations" @@ xty (snd ast.operations.value)
|
|> shadow "operations" @@ xty (snd operations.value)
|
||||||
in
|
in
|
||||||
let (ve',te'), lambdas = fold_map tc_lambda_decl (ve, te) ast.lambdas in
|
let (ve',te'), lambdas = fold_map tc_lambda_decl (ve, te) lambdas in
|
||||||
let (ve'', te''), block = tc_block (ve', te') (unreg ast.block) in
|
let (ve'', te''), block = tc_block (ve', te') (unreg block) in
|
||||||
let _ve'' = ve'' in (* not needed anymore *)
|
let _ve'' = ve'' in (* not needed anymore *)
|
||||||
let _te'' = te'' in (* not needed anymore *)
|
let _te'' = te'' in (* not needed anymore *)
|
||||||
mk_ast ~lambdas ~block
|
mk_ast ~lambdas ~block
|
||||||
|
*)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user