Threaded 'a parameter everywhere
This commit is contained in:
Your Name
parent
09f790680f
commit
40377a80df
497
AST.mli
497
AST.mli
@ -97,12 +97,12 @@ 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
|
||||
type 'a variable = string reg
|
||||
type 'a fun_name = string reg
|
||||
type 'a type_name = string reg
|
||||
type 'a field_name = string reg
|
||||
type 'a map_name = string reg
|
||||
type 'a constr = string reg
|
||||
|
||||
(* Comma-separated non-empty lists *)
|
||||
|
||||
@ -126,229 +126,229 @@ type 'a braces = (lbrace * 'a * rbrace) reg
|
||||
|
||||
(* The Abstract Syntax Tree *)
|
||||
|
||||
type t = {
|
||||
types : type_decl reg list;
|
||||
constants : const_decl reg list;
|
||||
parameter : parameter_decl reg;
|
||||
storage : storage_decl reg;
|
||||
operations : operations_decl reg;
|
||||
lambdas : lambda_decl list;
|
||||
block : block reg;
|
||||
eof : eof
|
||||
type t = < ty:unit > ast
|
||||
|
||||
and 'a ast = {
|
||||
types : 'a type_decl reg list;
|
||||
constants : 'a const_decl reg list;
|
||||
parameter : 'a parameter_decl reg;
|
||||
storage : 'a storage_decl reg;
|
||||
operations : 'a operations_decl reg;
|
||||
lambdas : 'a lambda_decl list;
|
||||
block : 'a block reg;
|
||||
eof : eof
|
||||
}
|
||||
|
||||
and ast = t
|
||||
|
||||
and parameter_decl = {
|
||||
kwd_parameter : kwd_parameter;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
param_type : type_expr;
|
||||
terminator : semi option
|
||||
and 'a parameter_decl = {
|
||||
kwd_parameter : kwd_parameter;
|
||||
name : 'a variable;
|
||||
colon : colon;
|
||||
param_type : 'a type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and storage_decl = {
|
||||
kwd_storage : kwd_storage;
|
||||
store_type : type_expr;
|
||||
terminator : semi option
|
||||
and 'a storage_decl = {
|
||||
kwd_storage : kwd_storage;
|
||||
store_type : 'a type_expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and operations_decl = {
|
||||
kwd_operations : kwd_operations;
|
||||
op_type : type_expr;
|
||||
terminator : semi option
|
||||
and 'a operations_decl = {
|
||||
kwd_operations : kwd_operations;
|
||||
op_type : 'a 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 'a type_decl = {
|
||||
kwd_type : kwd_type;
|
||||
name : 'a type_name;
|
||||
kwd_is : kwd_is;
|
||||
type_expr : 'a 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 'a type_expr =
|
||||
Prod of 'a cartesian
|
||||
| Sum of ('a variant, vbar) nsepseq reg
|
||||
| Record of 'a record_type
|
||||
| TypeApp of ('a type_name * 'a type_tuple) reg
|
||||
| ParType of 'a type_expr par
|
||||
| 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 *)
|
||||
|
||||
and lambda_decl =
|
||||
FunDecl of fun_decl reg
|
||||
| ProcDecl of proc_decl reg
|
||||
and 'a lambda_decl =
|
||||
FunDecl of 'a fun_decl reg
|
||||
| ProcDecl of 'a proc_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 'a fun_decl = {
|
||||
kwd_function : kwd_function;
|
||||
name : 'a variable;
|
||||
param : 'a parameters;
|
||||
colon : colon;
|
||||
ret_type : 'a type_expr;
|
||||
kwd_is : kwd_is;
|
||||
local_decls : 'a local_decl list;
|
||||
block : 'a block reg;
|
||||
kwd_with : kwd_with;
|
||||
return : 'a 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 'a proc_decl = {
|
||||
kwd_procedure : kwd_procedure;
|
||||
name : 'a variable;
|
||||
param : 'a parameters;
|
||||
kwd_is : kwd_is;
|
||||
local_decls : 'a local_decl list;
|
||||
block : 'a block reg;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and parameters = (param_decl, semi) nsepseq par
|
||||
and 'a parameters = ('a param_decl, semi) nsepseq par
|
||||
|
||||
and param_decl =
|
||||
ParamConst of param_const
|
||||
| ParamVar of param_var
|
||||
and 'a param_decl =
|
||||
ParamConst of 'a param_const
|
||||
| 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 = {
|
||||
opening : kwd_begin;
|
||||
instr : instructions;
|
||||
terminator : semi option;
|
||||
close : kwd_end
|
||||
and 'a block = {
|
||||
opening : kwd_begin;
|
||||
instr : 'a 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 'a local_decl =
|
||||
LocalLam of 'a lambda_decl
|
||||
| LocalConst of 'a const_decl reg
|
||||
| LocalVar of 'a var_decl reg
|
||||
|
||||
and const_decl = {
|
||||
kwd_const : kwd_const;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
vtype : type_expr;
|
||||
equal : equal;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
and 'a const_decl = {
|
||||
kwd_const : kwd_const;
|
||||
name : 'a variable;
|
||||
colon : colon;
|
||||
vtype : 'a type_expr;
|
||||
equal : equal;
|
||||
init : 'a expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and var_decl = {
|
||||
kwd_var : kwd_var;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
vtype : type_expr;
|
||||
ass : ass;
|
||||
init : expr;
|
||||
terminator : semi option
|
||||
and 'a var_decl = {
|
||||
kwd_var : kwd_var;
|
||||
name : 'a variable;
|
||||
colon : colon;
|
||||
vtype : 'a type_expr;
|
||||
ass : ass;
|
||||
init : 'a expr;
|
||||
terminator : semi option
|
||||
}
|
||||
|
||||
and instructions = (instruction, semi) nsepseq reg
|
||||
and 'a instructions = ('a instruction, semi) nsepseq reg
|
||||
|
||||
and instruction =
|
||||
Single of single_instr
|
||||
| Block of block reg
|
||||
and 'a instruction =
|
||||
Single of 'a single_instr
|
||||
| Block of 'a 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
|
||||
and 'a single_instr =
|
||||
Cond of 'a conditional reg
|
||||
| Match of 'a match_instr reg
|
||||
| Ass of 'a ass_instr
|
||||
| Loop of 'a loop
|
||||
| ProcCall of 'a fun_call
|
||||
| Null of kwd_null
|
||||
| Fail of (kwd_fail * expr) reg
|
||||
| Fail of (kwd_fail * 'a expr) reg
|
||||
|
||||
and conditional = {
|
||||
kwd_if : kwd_if;
|
||||
test : expr;
|
||||
kwd_then : kwd_then;
|
||||
ifso : instruction;
|
||||
kwd_else : kwd_else;
|
||||
ifnot : instruction
|
||||
and 'a conditional = {
|
||||
kwd_if : kwd_if;
|
||||
test : 'a expr;
|
||||
kwd_then : kwd_then;
|
||||
ifso : 'a instruction;
|
||||
kwd_else : kwd_else;
|
||||
ifnot : 'a 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 'a match_instr = {
|
||||
kwd_match : kwd_match;
|
||||
expr : 'a expr;
|
||||
kwd_with : kwd_with;
|
||||
lead_vbar : vbar option;
|
||||
cases : 'a cases;
|
||||
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 =
|
||||
While of while_loop
|
||||
| For of for_loop
|
||||
and 'a loop =
|
||||
While of 'a while_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 =
|
||||
ForInt of for_int reg
|
||||
| ForCollect of for_collect reg
|
||||
and 'a for_loop =
|
||||
ForInt of 'a for_int reg
|
||||
| ForCollect of 'a 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 'a for_int = {
|
||||
kwd_for : kwd_for;
|
||||
ass : 'a ass_instr;
|
||||
down : kwd_down option;
|
||||
kwd_to : kwd_to;
|
||||
bound : 'a expr;
|
||||
step : (kwd_step * 'a expr) option;
|
||||
block : 'a 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
|
||||
and 'a for_collect = {
|
||||
kwd_for : kwd_for;
|
||||
var : 'a variable;
|
||||
bind_to : (arrow * 'a variable) option;
|
||||
kwd_in : kwd_in;
|
||||
expr : 'a expr;
|
||||
block : 'a 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
|
||||
and 'a expr =
|
||||
Or of ('a expr * bool_or * 'a expr) reg
|
||||
| And of ('a expr * bool_and * 'a expr) reg
|
||||
| Lt of ('a expr * lt * 'a expr) reg
|
||||
| Leq of ('a expr * leq * 'a expr) reg
|
||||
| Gt of ('a expr * gt * 'a expr) reg
|
||||
| Geq of ('a expr * geq * 'a expr) reg
|
||||
| Equal of ('a expr * equal * 'a expr) reg
|
||||
| Neq of ('a expr * neq * 'a expr) reg
|
||||
| Cat of ('a expr * cat * 'a expr) reg
|
||||
| Cons of ('a expr * cons * 'a expr) reg
|
||||
| Add of ('a expr * plus * 'a expr) reg
|
||||
| Sub of ('a expr * minus * 'a expr) reg
|
||||
| Mult of ('a expr * times * 'a expr) reg
|
||||
| Div of ('a expr * slash * 'a expr) reg
|
||||
| Mod of ('a expr * kwd_mod * 'a expr) reg
|
||||
| Neg of (minus * 'a expr) reg
|
||||
| Not of (kwd_not * 'a expr) reg
|
||||
| Int of (Lexer.lexeme * Z.t) reg
|
||||
| Var of Lexer.lexeme reg
|
||||
| String of Lexer.lexeme reg
|
||||
@ -356,46 +356,46 @@ and expr =
|
||||
| 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
|
||||
| Tuple of 'a tuple
|
||||
| List of ('a expr, comma) nsepseq brackets
|
||||
| EmptyList of 'a empty_list
|
||||
| Set of ('a expr, comma) nsepseq braces
|
||||
| EmptySet of 'a empty_set
|
||||
| NoneExpr of 'a none_expr
|
||||
| FunCall of 'a fun_call
|
||||
| ConstrApp of 'a constr_app
|
||||
| SomeApp of (c_Some * 'a arguments) reg
|
||||
| MapLookUp of 'a map_lookup reg
|
||||
| ParExpr of 'a expr par
|
||||
|
||||
and tuple = (expr, comma) nsepseq par
|
||||
and 'a tuple = ('a expr, comma) nsepseq par
|
||||
|
||||
and empty_list =
|
||||
(lbracket * rbracket * colon * type_expr) par
|
||||
and 'a empty_list =
|
||||
(lbracket * rbracket * colon * 'a type_expr) par
|
||||
|
||||
and empty_set =
|
||||
(lbrace * rbrace * colon * type_expr) par
|
||||
and 'a empty_set =
|
||||
(lbrace * rbrace * colon * 'a type_expr) par
|
||||
|
||||
and none_expr =
|
||||
(c_None * colon * type_expr) par
|
||||
and 'a none_expr =
|
||||
(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 = {
|
||||
map_name : variable;
|
||||
selector : dot;
|
||||
index : expr brackets
|
||||
and 'a map_lookup = {
|
||||
map_name : 'a variable;
|
||||
selector : dot;
|
||||
index : 'a expr brackets
|
||||
}
|
||||
|
||||
(* 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
|
||||
| PWild of wild
|
||||
| PInt of (Lexer.lexeme * Z.t) reg
|
||||
@ -405,26 +405,97 @@ and core_pattern =
|
||||
| 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
|
||||
| PSome of (c_Some * 'a core_pattern par) reg
|
||||
| PList of 'a list_pattern
|
||||
| PTuple of ('a core_pattern, comma) nsepseq par
|
||||
|
||||
and list_pattern =
|
||||
Sugar of (core_pattern, comma) sepseq brackets
|
||||
| Raw of (core_pattern * cons * pattern) par
|
||||
and 'a list_pattern =
|
||||
Sugar of ('a core_pattern, comma) sepseq brackets
|
||||
| Raw of ('a core_pattern * cons * 'a pattern) par
|
||||
|
||||
(* 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 *)
|
||||
|
||||
val print_tokens : t -> unit
|
||||
type 'a visitor = {
|
||||
ass_instr : 'a ass_instr -> 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
|
||||
let ast = Parser.program tokeniser buffer in
|
||||
if Utils.String.Set.mem "parser" EvalOpt.verbose
|
||||
then AST.print_tokens ast
|
||||
then Print.print_tokens ast
|
||||
with
|
||||
Lexer.Error err ->
|
||||
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
|
||||
116
typecheck.ml
116
typecheck.ml
@ -1,3 +1,9 @@
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(*
|
||||
module I = AST (* In *)
|
||||
|
||||
module SMap = Map.Make(String)
|
||||
@ -35,27 +41,28 @@ module O = struct
|
||||
| ProcDecl of proc_decl
|
||||
|
||||
and fun_decl = {
|
||||
local_decls : local_decls;
|
||||
kwd_function : kwd_function;
|
||||
var : variable;
|
||||
name : variable;
|
||||
param : parameters;
|
||||
colon : colon;
|
||||
ret_type : type_expr;
|
||||
kwd_is : kwd_is;
|
||||
body : block;
|
||||
kwd_with : kwd_with;
|
||||
return : checked_expr
|
||||
return : expr
|
||||
}
|
||||
|
||||
and proc_decl = {
|
||||
kwd_procedure : kwd_procedure;
|
||||
var : variable;
|
||||
name : variable;
|
||||
param : parameters;
|
||||
kwd_is : kwd_is;
|
||||
body : block
|
||||
local_decls : local_decl list;
|
||||
block : block reg
|
||||
}
|
||||
|
||||
and block = {
|
||||
decls : value_decls;
|
||||
opening : kwd_begin;
|
||||
instr : instructions;
|
||||
close : kwd_end
|
||||
@ -64,28 +71,21 @@ module O = struct
|
||||
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
|
||||
kwd_var : kwd_var;
|
||||
name : variable;
|
||||
colon : colon;
|
||||
vtype : type_expr;
|
||||
asgnmnt : Region.t; (* "=" or ":=" *)
|
||||
init : expr
|
||||
}
|
||||
|
||||
and checked_expr = {ty:type_expr;expr:expr}
|
||||
and 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}
|
||||
|
||||
(* open Sanity: *)
|
||||
let (|>) v f = f v (* pipe f to 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))
|
||||
|> 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 param_const_to_xty : 'todo -> O.type_expr = function
|
||||
(_kwd_const, _variable, _colon, type_expr) -> O.Mutable (xty type_expr)
|
||||
|
||||
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
|
||||
|> 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)
|
||||
|
||||
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
|
||||
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 =
|
||||
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}
|
||||
fun (ve,te) {kwd_var;name;colon;vtype;asgnmnt;init} ->
|
||||
let vtype = (xty vtype) in
|
||||
let init = tc_expr (ve,te) init vtype in
|
||||
let ve,te = shadow (unreg name) vtype ve, te in
|
||||
(ve,te), {kwd_var;name;colon;vtype;asgnmnt;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 opening,instr,close = block.opening, block.instr, block.close in
|
||||
(ve,te), O.{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_local_decl : I.local_decl -> 'todo =
|
||||
`TODO
|
||||
|
||||
let tc_proc_decl : vte -> I.proc_decl -> vte*O.proc_decl =
|
||||
fun vte {kwd_procedure;name;param;kwd_is;local_decls;block} ->
|
||||
let vte, local_decls = tc_var_decls vte (local_decls |> map tc_local_decl) in
|
||||
let vte, block = tc_block vte (unreg block)
|
||||
in vte,{kwd_procedure;name;param;kwd_is;local_decls;block}
|
||||
|
||||
let tc_fun_decl : vte -> I.fun_decl -> O.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 =
|
||||
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
|
||||
FunDecl {value;_} -> shadow value.name.value (params_to_xty value.param (xty value.ret_type)) 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 =
|
||||
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 =
|
||||
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 *)
|
||||
let te =
|
||||
SMap.empty
|
||||
|> type_decls_to_tenv ast.types in
|
||||
|> type_decls_to_tenv 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)
|
||||
|> (match parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty)
|
||||
|> shadow "storage" @@ xty (snd storage.value)
|
||||
|> shadow "operations" @@ xty (snd 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',te'), lambdas = fold_map tc_lambda_decl (ve, te) lambdas in
|
||||
let (ve'', te''), block = tc_block (ve', te') (unreg 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