diff --git a/AST.ml b/AST.ml index c9596c183..7726673f9 100644 --- a/AST.ml +++ b/AST.ml @@ -113,12 +113,12 @@ type eof = Region.t (* Literals *) -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 +type variable = string reg +type fun_name = string reg +type type_name = string reg +type field_name = string reg +type map_name = string reg +type constr = string reg (* Comma-separated non-empty lists *) @@ -142,229 +142,229 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -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 +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 } -and 'a parameter_decl = { - kwd_parameter : kwd_parameter; - name : 'a variable; - colon : colon; - param_type : 'a type_expr; - terminator : semi option +and ast = t + +and parameter_decl = { + kwd_parameter : kwd_parameter; + name : variable; + colon : colon; + param_type : type_expr; + terminator : semi option } -and 'a storage_decl = { - kwd_storage : kwd_storage; - store_type : 'a type_expr; - terminator : semi option +and storage_decl = { + kwd_storage : kwd_storage; + store_type : type_expr; + terminator : semi option } -and 'a operations_decl = { - kwd_operations : kwd_operations; - op_type : 'a type_expr; - terminator : semi option +and operations_decl = { + kwd_operations : kwd_operations; + op_type : type_expr; + terminator : semi option } (* Type declarations *) -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_decl = { + kwd_type : kwd_type; + name : type_name; + kwd_is : kwd_is; + type_expr : type_expr; + terminator : semi option } -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 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 cartesian = ('a type_expr, times) nsepseq reg +and cartesian = (type_expr, times) nsepseq reg -and 'a variant = ('a constr * kwd_of * 'a cartesian) reg +and variant = (constr * kwd_of * cartesian) reg -and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg +and record_type = (kwd_record * field_decls * kwd_end) reg -and 'a field_decls = ('a field_decl, semi) nsepseq +and field_decls = (field_decl, semi) nsepseq -and 'a field_decl = ('a variable * colon * 'a type_expr) reg +and field_decl = (variable * colon * type_expr) reg -and 'a type_tuple = ('a type_name, comma) nsepseq par +and type_tuple = (type_name, comma) nsepseq par (* Function and procedure declarations *) -and 'a lambda_decl = - FunDecl of 'a fun_decl reg -| ProcDecl of 'a proc_decl reg +and lambda_decl = + FunDecl of fun_decl reg +| ProcDecl of proc_decl reg -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 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 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 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 parameters = ('a param_decl, semi) nsepseq par +and parameters = (param_decl, semi) nsepseq par -and 'a param_decl = - ParamConst of 'a param_const -| ParamVar of 'a param_var +and param_decl = + ParamConst of param_const +| ParamVar of param_var -and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg +and param_const = (kwd_const * variable * colon * type_expr) reg -and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg +and param_var = (kwd_var * variable * colon * type_expr) reg -and 'a block = { - opening : kwd_begin; - instr : 'a instructions; - terminator : semi option; - close : kwd_end +and block = { + opening : kwd_begin; + instr : instructions; + terminator : semi option; + close : kwd_end } -and 'a local_decl = - LocalLam of 'a lambda_decl -| LocalConst of 'a const_decl reg -| LocalVar of 'a var_decl reg +and local_decl = + LocalLam of lambda_decl +| LocalConst of const_decl reg +| LocalVar of var_decl reg -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 const_decl = { + kwd_const : kwd_const; + name : variable; + colon : colon; + vtype : type_expr; + equal : equal; + 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 var_decl = { + kwd_var : kwd_var; + name : variable; + colon : colon; + vtype : type_expr; + ass : ass; + init : expr; + terminator : semi option } -and 'a instructions = ('a instruction, semi) nsepseq reg +and instructions = (instruction, semi) nsepseq reg -and 'a instruction = - Single of 'a single_instr -| Block of 'a block reg +and instruction = + Single of single_instr +| Block of block reg -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 +and single_instr = + Cond of conditional reg +| Match of match_instr reg +| Ass of ass_instr +| Loop of loop +| ProcCall of fun_call | Null of kwd_null -| Fail of (kwd_fail * 'a expr) reg +| Fail of (kwd_fail * expr) reg -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 conditional = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : instruction; + kwd_else : kwd_else; + ifnot : instruction } -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 match_instr = { + kwd_match : kwd_match; + expr : expr; + kwd_with : kwd_with; + lead_vbar : vbar option; + cases : cases; + kwd_end : kwd_end } -and 'a cases = ('a case, vbar) nsepseq reg +and cases = (case, vbar) nsepseq reg -and 'a case = ('a pattern * arrow * 'a instruction) reg +and case = (pattern * arrow * instruction) reg -and 'a ass_instr = ('a variable * ass * 'a expr) reg +and ass_instr = (variable * ass * expr) reg -and 'a loop = - While of 'a while_loop -| For of 'a for_loop +and loop = + While of while_loop +| For of for_loop -and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg +and while_loop = (kwd_while * expr * block reg) reg -and 'a for_loop = - ForInt of 'a for_int reg -| ForCollect of 'a for_collect reg +and for_loop = + ForInt of for_int reg +| ForCollect of for_collect 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_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_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 +and for_collect = { + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + kwd_in : kwd_in; + expr : expr; + block : block reg } (* Expressions *) -and '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 +and expr = + Or of (expr * bool_or * expr) reg +| And of (expr * bool_and * expr) reg +| Lt of (expr * lt * expr) reg +| Leq of (expr * leq * expr) reg +| Gt of (expr * gt * expr) reg +| Geq of (expr * geq * expr) reg +| Equal of (expr * equal * expr) reg +| Neq of (expr * neq * expr) reg +| Cat of (expr * cat * expr) reg +| Cons of (expr * cons * expr) reg +| Add of (expr * plus * expr) reg +| Sub of (expr * minus * expr) reg +| Mult of (expr * times * expr) reg +| Div of (expr * slash * expr) reg +| Mod of (expr * kwd_mod * expr) reg +| Neg of (minus * expr) reg +| Not of (kwd_not * expr) reg | Int of (Lexer.lexeme * Z.t) reg | Var of Lexer.lexeme reg | String of Lexer.lexeme reg @@ -372,46 +372,46 @@ and 'a expr = | False of c_False | True of c_True | Unit of c_Unit -| 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 +| Tuple of tuple +| List of (expr, comma) nsepseq brackets +| EmptyList of empty_list +| Set of (expr, comma) nsepseq braces +| EmptySet of empty_set +| NoneExpr of none_expr +| FunCall of fun_call +| ConstrApp of constr_app +| SomeApp of (c_Some * arguments) reg +| MapLookUp of map_lookup reg +| ParExpr of expr par -and 'a tuple = ('a expr, comma) nsepseq par +and tuple = (expr, comma) nsepseq par -and 'a empty_list = - (lbracket * rbracket * colon * 'a type_expr) par +and empty_list = + (lbracket * rbracket * colon * type_expr) par -and 'a empty_set = - (lbrace * rbrace * colon * 'a type_expr) par +and empty_set = + (lbrace * rbrace * colon * type_expr) par -and 'a none_expr = - (c_None * colon * 'a type_expr) par +and none_expr = + (c_None * colon * type_expr) par -and 'a fun_call = ('a fun_name * 'a arguments) reg +and fun_call = (fun_name * arguments) reg -and 'a arguments = 'a tuple +and arguments = tuple -and 'a constr_app = ('a constr * 'a arguments) reg +and constr_app = (constr * arguments) reg -and 'a map_lookup = { - map_name : 'a variable; +and map_lookup = { + map_name : variable; selector : dot; - index : 'a expr brackets + index : expr brackets } (* Patterns *) -and 'a pattern = ('a core_pattern, cons) nsepseq reg +and pattern = (core_pattern, cons) nsepseq reg -and 'a core_pattern = +and core_pattern = PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -421,13 +421,13 @@ and 'a core_pattern = | PFalse of c_False | PTrue of c_True | PNone of c_None -| PSome of (c_Some * 'a core_pattern par) reg -| PList of 'a list_pattern -| PTuple of ('a core_pattern, comma) nsepseq par +| PSome of (c_Some * core_pattern par) reg +| PList of list_pattern +| PTuple of (core_pattern, comma) nsepseq par -and 'a list_pattern = - Sugar of ('a core_pattern, comma) sepseq brackets -| Raw of ('a core_pattern * cons * 'a pattern) par +and list_pattern = + Sugar of (core_pattern, comma) sepseq brackets +| Raw of (core_pattern * cons * pattern) par (* Projecting regions *) @@ -513,77 +513,647 @@ let local_decl_to_region = function (* Printing the tokens with their source regions *) -type 'a visitor = { - ass_instr : 'a ass_instr -> unit; - bind_to : (region * 'a variable) option -> unit; - block : 'a block reg -> unit; +type visitor = { + ass_instr : ass_instr -> unit; + bind_to : (region * variable) option -> unit; + block : 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; + cartesian : cartesian -> unit; + case : case -> unit; + cases : cases -> unit; + conditional : conditional -> unit; + const_decl : const_decl reg -> unit; + constr : constr -> unit; + constr_app : constr_app -> unit; + core_pattern : core_pattern -> unit; down : region 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; + empty_list : empty_list -> unit; + empty_set : empty_set -> unit; + expr : expr -> unit; + fail : (kwd_fail * expr) -> unit; + field_decl : field_decl -> unit; + field_decls : field_decls -> unit; + for_collect : for_collect reg -> unit; + for_int : for_int reg -> unit; + for_loop : for_loop -> unit; + fun_call : fun_call -> unit; + fun_decl : fun_decl reg -> unit; + instruction : instruction -> unit; + instructions : instructions -> unit; int : (string * Z.t) reg -> unit; - lambda_decl : 'a lambda_decl -> unit; - list : ('a expr, region) 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; + lambda_decl : lambda_decl -> unit; + list : (expr, region) nsepseq brackets -> unit; + list_pattern : list_pattern -> unit; + loop : loop -> unit; + map_lookup : map_lookup reg -> unit; + match_instr : match_instr -> unit; + none_expr : none_expr -> unit; nsepseq : 'a.string -> ('a -> unit) -> ('a, region) 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 * 'a core_pattern par) reg -> unit; - ptuple : ('a core_pattern, region) nsepseq par -> unit; - raw : ('a core_pattern * region * 'a pattern) par -> unit; - record_type : 'a record_type -> unit; + operations_decl : operations_decl reg -> unit; + par_expr : expr par -> unit; + par_type : type_expr par -> unit; + param_decl : param_decl -> unit; + parameter_decl : parameter_decl reg -> unit; + parameters : parameters -> unit; + param_const : param_const -> unit; + param_var : param_var -> unit; + pattern : pattern -> unit; + patterns : core_pattern par -> unit; + proc_decl : proc_decl reg -> unit; + psome : (region * core_pattern par) reg -> unit; + ptuple : (core_pattern, region) nsepseq par -> unit; + raw : (core_pattern * region * pattern) par -> unit; + record_type : record_type -> unit; sepseq : 'a.string -> ('a -> unit) -> ('a, region) sepseq -> unit; - set : ('a expr, region) nsepseq braces -> unit; - single_instr : 'a single_instr -> unit; - some_app : (region * 'a arguments) reg -> unit; - step : (region * 'a expr) option -> unit; - storage_decl : 'a storage_decl reg -> unit; + set : (expr, region) nsepseq braces -> unit; + single_instr : single_instr -> unit; + some_app : (region * arguments) reg -> unit; + step : (region * expr) option -> unit; + storage_decl : storage_decl reg -> unit; string : string reg -> unit; - sugar : ('a core_pattern, region) sepseq brackets -> unit; - sum_type : ('a variant, region) nsepseq reg -> unit; + sugar : (core_pattern, region) sepseq brackets -> unit; + sum_type : (variant, region) nsepseq reg -> unit; terminator : semi option -> unit; token : region -> 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 + tuple : arguments -> unit; + type_app : (type_name * type_tuple) reg -> unit; + type_decl : type_decl reg -> unit; + type_expr : type_expr -> unit; + type_tuple : type_tuple -> unit; + local_decl : local_decl -> unit; + local_decls : local_decl list -> unit; + var : variable -> unit; + var_decl : var_decl reg -> unit; + variant : variant -> unit; + while_loop : while_loop -> unit } + +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: 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: 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: visitor) {value=node; _} = + v.token node.kwd_storage "storage"; + v.type_expr node.store_type; + v.terminator node.terminator + +and print_operations_decl (v: visitor) {value=node; _} = + v.token node.kwd_operations "operations"; + v.type_expr node.op_type; + v.terminator node.terminator + +and print_type_decl (v: 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: 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: visitor) {value=sequence; _} = + v.nsepseq "*" v.type_expr sequence + +and print_variant (v: 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: visitor) {value=sequence; _} = + v.nsepseq "|" v.variant sequence + +and print_record_type (v: 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: visitor) {value=node; _} = + let type_name, type_tuple = node in + v.var type_name; + v.type_tuple type_tuple + +and print_par_type (v: 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: visitor) sequence = + v.nsepseq ";" v.field_decl sequence + +and print_field_decl (v: 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: 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: visitor) = function + FunDecl fun_decl -> v.fun_decl fun_decl +| ProcDecl proc_decl -> v.proc_decl proc_decl + +and print_fun_decl (v: 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: 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: 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: visitor) = function + ParamConst param_const -> v.param_const param_const +| ParamVar param_var -> v.param_var param_var + +and print_param_const (v: 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: 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: 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: visitor) sequence = + List.iter v.local_decl sequence + +and print_local_decl (v: 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: 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: 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: visitor) {value=sequence; _} = + v.nsepseq ";" v.instruction sequence + +and print_instruction (v: visitor) = function + Single instr -> v.single_instr instr +| Block block -> v.block block + +and print_single_instr (v: 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: visitor) (kwd_fail, expr) = + v.token kwd_fail "fail"; + v.expr expr + +and print_conditional (v: 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: 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: visitor) {value=sequence; _} = + v.nsepseq "|" v.case sequence + +and print_case (v: visitor) {value=node; _} = + let pattern, arrow, instruction = node in + v.pattern pattern; + v.token arrow "->"; + v.instruction instruction + +and print_ass_instr (v: visitor) {value=node; _} = + let variable, ass, expr = node in + v.var variable; + v.token ass ":="; + v.expr expr + +and print_loop (v: visitor) = function + While while_loop -> v.while_loop while_loop +| For for_loop -> v.for_loop for_loop + +and print_while_loop (v: 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: visitor) = function + ForInt for_int -> v.for_int for_int +| ForCollect for_collect -> v.for_collect for_collect + +and print_for_int (v: visitor) ({value=node; _} : 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: visitor) = function + Some kwd_down -> v.token kwd_down "down" +| None -> () + +and print_step (v: visitor) = function + Some (kwd_step, expr) -> + v.token kwd_step "step"; + v.expr expr +| None -> () + +and print_for_collect (v: visitor) ({value=node; _} : 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: visitor) = function + Some (arrow, variable) -> + v.token arrow "->"; + v.var variable +| None -> () + +and print_expr (v: 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: visitor) {value=node; _} = + let lpar, sequence, rpar = node in + v.token lpar "("; + v.nsepseq "," v.expr sequence; + v.token rpar ")" + +and print_list (v: 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: 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: 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: 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: 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: visitor) {value=node; _} = + let fun_name, arguments = node in + v.var fun_name; + v.tuple arguments + +and print_constr_app (v: visitor) {value=node; _} = + let constr, arguments = node in + v.constr constr; + v.tuple arguments + +and print_some_app (v: visitor) {value=node; _} = + let c_Some, arguments = node in + v.token c_Some "Some"; + v.tuple arguments + +and print_map_lookup (v: 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: visitor) {value=node; _} = + let lpar, expr, rpar = node in + v.token lpar "("; + v.expr expr; + v.token rpar ")" + +and print_pattern (v: visitor) {value=sequence; _} = + v.nsepseq "<:" v.core_pattern sequence + +and print_core_pattern (v: 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: visitor) {value=node; _} = + let c_Some, patterns = node in + v.token c_Some "Some"; + v.patterns patterns + +and print_patterns (v: 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: visitor) = function + Sugar sugar -> v.sugar sugar +| Raw raw -> v.raw raw + +and print_sugar (v: 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: 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: 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: visitor) = function + Some semi -> v.token semi ";" +| None -> () + +let rec visitor () : 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 ()) diff --git a/AST.mli b/AST.mli index 3505f44d2..e8a812ec7 100644 --- a/AST.mli +++ b/AST.mli @@ -97,12 +97,12 @@ type eof = Region.t (* Literals *) -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 +type variable = string reg +type fun_name = string reg +type type_name = string reg +type field_name = string reg +type map_name = string reg +type constr = string reg (* Comma-separated non-empty lists *) @@ -126,229 +126,229 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -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 +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 } -and 'a parameter_decl = { - kwd_parameter : kwd_parameter; - name : 'a variable; - colon : colon; - param_type : 'a type_expr; - terminator : semi option +and ast = t + +and parameter_decl = { + kwd_parameter : kwd_parameter; + name : variable; + colon : colon; + param_type : type_expr; + terminator : semi option } -and 'a storage_decl = { - kwd_storage : kwd_storage; - store_type : 'a type_expr; - terminator : semi option +and storage_decl = { + kwd_storage : kwd_storage; + store_type : type_expr; + terminator : semi option } -and 'a operations_decl = { - kwd_operations : kwd_operations; - op_type : 'a type_expr; - terminator : semi option +and operations_decl = { + kwd_operations : kwd_operations; + op_type : type_expr; + terminator : semi option } (* Type declarations *) -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_decl = { + kwd_type : kwd_type; + name : type_name; + kwd_is : kwd_is; + type_expr : type_expr; + terminator : semi option } -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 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 cartesian = ('a type_expr, times) nsepseq reg +and cartesian = (type_expr, times) nsepseq reg -and 'a variant = ('a constr * kwd_of * 'a cartesian) reg +and variant = (constr * kwd_of * cartesian) reg -and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg +and record_type = (kwd_record * field_decls * kwd_end) reg -and 'a field_decls = ('a field_decl, semi) nsepseq +and field_decls = (field_decl, semi) nsepseq -and 'a field_decl = ('a variable * colon * 'a type_expr) reg +and field_decl = (variable * colon * type_expr) reg -and 'a type_tuple = ('a type_name, comma) nsepseq par +and type_tuple = (type_name, comma) nsepseq par (* Function and procedure declarations *) -and 'a lambda_decl = - FunDecl of 'a fun_decl reg -| ProcDecl of 'a proc_decl reg +and lambda_decl = + FunDecl of fun_decl reg +| ProcDecl of proc_decl reg -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 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 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 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 parameters = ('a param_decl, semi) nsepseq par +and parameters = (param_decl, semi) nsepseq par -and 'a param_decl = - ParamConst of 'a param_const -| ParamVar of 'a param_var +and param_decl = + ParamConst of param_const +| ParamVar of param_var -and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg +and param_const = (kwd_const * variable * colon * type_expr) reg -and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg +and param_var = (kwd_var * variable * colon * type_expr) reg -and 'a block = { - opening : kwd_begin; - instr : 'a instructions; - terminator : semi option; - close : kwd_end +and block = { + opening : kwd_begin; + instr : instructions; + terminator : semi option; + close : kwd_end } -and 'a local_decl = - LocalLam of 'a lambda_decl -| LocalConst of 'a const_decl reg -| LocalVar of 'a var_decl reg +and local_decl = + LocalLam of lambda_decl +| LocalConst of const_decl reg +| LocalVar of var_decl reg -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 const_decl = { + kwd_const : kwd_const; + name : variable; + colon : colon; + vtype : type_expr; + equal : equal; + 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 var_decl = { + kwd_var : kwd_var; + name : variable; + colon : colon; + vtype : type_expr; + ass : ass; + init : expr; + terminator : semi option } -and 'a instructions = ('a instruction, semi) nsepseq reg +and instructions = (instruction, semi) nsepseq reg -and 'a instruction = - Single of 'a single_instr -| Block of 'a block reg +and instruction = + Single of single_instr +| Block of block reg -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 +and single_instr = + Cond of conditional reg +| Match of match_instr reg +| Ass of ass_instr +| Loop of loop +| ProcCall of fun_call | Null of kwd_null -| Fail of (kwd_fail * 'a expr) reg +| Fail of (kwd_fail * expr) reg -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 conditional = { + kwd_if : kwd_if; + test : expr; + kwd_then : kwd_then; + ifso : instruction; + kwd_else : kwd_else; + ifnot : instruction } -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 match_instr = { + kwd_match : kwd_match; + expr : expr; + kwd_with : kwd_with; + lead_vbar : vbar option; + cases : cases; + kwd_end : kwd_end } -and 'a cases = ('a case, vbar) nsepseq reg +and cases = (case, vbar) nsepseq reg -and 'a case = ('a pattern * arrow * 'a instruction) reg +and case = (pattern * arrow * instruction) reg -and 'a ass_instr = ('a variable * ass * 'a expr) reg +and ass_instr = (variable * ass * expr) reg -and 'a loop = - While of 'a while_loop -| For of 'a for_loop +and loop = + While of while_loop +| For of for_loop -and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg +and while_loop = (kwd_while * expr * block reg) reg -and 'a for_loop = - ForInt of 'a for_int reg -| ForCollect of 'a for_collect reg +and for_loop = + ForInt of for_int reg +| ForCollect of for_collect 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_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_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 +and for_collect = { + kwd_for : kwd_for; + var : variable; + bind_to : (arrow * variable) option; + kwd_in : kwd_in; + expr : expr; + block : block reg } (* Expressions *) -and '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 +and expr = + Or of (expr * bool_or * expr) reg +| And of (expr * bool_and * expr) reg +| Lt of (expr * lt * expr) reg +| Leq of (expr * leq * expr) reg +| Gt of (expr * gt * expr) reg +| Geq of (expr * geq * expr) reg +| Equal of (expr * equal * expr) reg +| Neq of (expr * neq * expr) reg +| Cat of (expr * cat * expr) reg +| Cons of (expr * cons * expr) reg +| Add of (expr * plus * expr) reg +| Sub of (expr * minus * expr) reg +| Mult of (expr * times * expr) reg +| Div of (expr * slash * expr) reg +| Mod of (expr * kwd_mod * expr) reg +| Neg of (minus * expr) reg +| Not of (kwd_not * expr) reg | Int of (Lexer.lexeme * Z.t) reg | Var of Lexer.lexeme reg | String of Lexer.lexeme reg @@ -356,46 +356,46 @@ and 'a expr = | False of c_False | True of c_True | Unit of c_Unit -| 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 +| Tuple of tuple +| List of (expr, comma) nsepseq brackets +| EmptyList of empty_list +| Set of (expr, comma) nsepseq braces +| EmptySet of empty_set +| NoneExpr of none_expr +| FunCall of fun_call +| ConstrApp of constr_app +| SomeApp of (c_Some * arguments) reg +| MapLookUp of map_lookup reg +| ParExpr of expr par -and 'a tuple = ('a expr, comma) nsepseq par +and tuple = (expr, comma) nsepseq par -and 'a empty_list = - (lbracket * rbracket * colon * 'a type_expr) par +and empty_list = + (lbracket * rbracket * colon * type_expr) par -and 'a empty_set = - (lbrace * rbrace * colon * 'a type_expr) par +and empty_set = + (lbrace * rbrace * colon * type_expr) par -and 'a none_expr = - (c_None * colon * 'a type_expr) par +and none_expr = + (c_None * colon * type_expr) par -and 'a fun_call = ('a fun_name * 'a arguments) reg +and fun_call = (fun_name * arguments) reg -and 'a arguments = 'a tuple +and arguments = tuple -and 'a constr_app = ('a constr * 'a arguments) reg +and constr_app = (constr * arguments) reg -and 'a map_lookup = { - map_name : 'a variable; - selector : dot; - index : 'a expr brackets +and map_lookup = { + map_name : variable; + selector : dot; + index : expr brackets } (* Patterns *) -and 'a pattern = ('a core_pattern, cons) nsepseq reg +and pattern = (core_pattern, cons) nsepseq reg -and 'a core_pattern = +and core_pattern = PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -405,97 +405,26 @@ and 'a core_pattern = | PFalse of c_False | PTrue of c_True | PNone of c_None -| PSome of (c_Some * 'a core_pattern par) reg -| PList of 'a list_pattern -| PTuple of ('a core_pattern, comma) nsepseq par +| PSome of (c_Some * core_pattern par) reg +| PList of list_pattern +| PTuple of (core_pattern, comma) nsepseq par -and 'a list_pattern = - Sugar of ('a core_pattern, comma) sepseq brackets -| Raw of ('a core_pattern * cons * 'a pattern) par +and list_pattern = + Sugar of (core_pattern, comma) sepseq brackets +| Raw of (core_pattern * cons * pattern) par (* Projecting regions *) -val type_expr_to_region : 'a type_expr -> Region.t +val type_expr_to_region : type_expr -> Region.t -val expr_to_region : 'a expr -> Region.t +val expr_to_region : expr -> Region.t -val instr_to_region : 'a instruction -> Region.t +val instr_to_region : instruction -> Region.t -val core_pattern_to_region : 'a core_pattern -> Region.t +val core_pattern_to_region : core_pattern -> Region.t -val local_decl_to_region : 'a local_decl -> Region.t +val local_decl_to_region : local_decl -> Region.t -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 -} +(* Printing *) + +val print_tokens : t -> unit diff --git a/ParserMain.ml b/ParserMain.ml index 0c940bfb6..0081d3c87 100644 --- a/ParserMain.ml +++ b/ParserMain.ml @@ -58,7 +58,7 @@ let () = try let ast = Parser.program tokeniser buffer in if Utils.String.Set.mem "parser" EvalOpt.verbose - then Print.print_tokens ast + then AST.print_tokens ast with Lexer.Error err -> close_all (); diff --git a/Print.ml b/Print.ml deleted file mode 100644 index 50f5e19dc..000000000 --- a/Print.ml +++ /dev/null @@ -1,573 +0,0 @@ -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 ()) diff --git a/Print.mli b/Print.mli deleted file mode 100644 index 66fae6dfa..000000000 --- a/Print.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* Printing *) - -open AST - -val print_tokens : t -> unit diff --git a/typecheck.ml b/typecheck.ml index b768a9949..99037d0bb 100644 --- a/typecheck.ml +++ b/typecheck.ml @@ -1,9 +1,3 @@ - - - - - -(* module I = AST (* In *) module SMap = Map.Make(String) @@ -41,28 +35,27 @@ module O = struct | ProcDecl of proc_decl and fun_decl = { - local_decls : local_decls; kwd_function : kwd_function; - name : variable; + var : variable; param : parameters; colon : colon; ret_type : type_expr; kwd_is : kwd_is; body : block; kwd_with : kwd_with; - return : expr + return : checked_expr } and proc_decl = { kwd_procedure : kwd_procedure; - name : variable; + var : variable; param : parameters; kwd_is : kwd_is; - local_decls : local_decl list; - block : block reg + body : block } and block = { + decls : value_decls; opening : kwd_begin; instr : instructions; close : kwd_end @@ -71,21 +64,28 @@ module O = struct and value_decls = var_decl list and var_decl = { - kwd_var : kwd_var; - name : variable; - colon : colon; - vtype : type_expr; - asgnmnt : Region.t; (* "=" or ":=" *) - init : expr + kind : var_kind; + var : variable; + colon : colon; + vtype : type_expr; + setter : Region.t; (* "=" or ":=" *) + init : checked_expr } - and expr = {ty:type_expr;expr:expr} + and checked_expr = {ty:type_expr;expr:expr} end [@warning "-30"] open O open AST open Region +let mk_checked_expr ~ty ~expr = {ty;expr} +let mk_proc_decl ~kwd_procedure ~var ~param ~kwd_is ~body = + O.{kwd_procedure; var; param; kwd_is; body} +let mk_ast ~lambdas ~block = {lambdas;block} +let mk_fun_decl ~kwd_function ~var ~param ~colon ~ret_type ~kwd_is ~body ~kwd_with ~return = + O.{kwd_function; var; param; colon; ret_type; kwd_is; body; kwd_with; return} + (* open Sanity: *) let (|>) v f = f v (* pipe f to v *) let (@@) f v = f v (* apply f on v *) @@ -130,20 +130,16 @@ 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 param_const_to_xty : 'todo -> O.type_expr = function - (_kwd_const, _variable, _colon, type_expr) -> O.Mutable (xty type_expr) +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_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 = +let params_to_xty params ret_type = unpar params |> nsepseq_to_list - |> map param_decl_to_xty + |> map (fun {value=(var_kind, _variable, _colon, type_expr);_} -> var_kind_to_ty var_kind type_expr) |> fun param_types -> O.Function (param_types, ret_type) let type_equal t1 t2 = match t1,t2 with @@ -157,29 +153,37 @@ 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 : I.expr) (expected:O.type_expr) : O.expr = {ty=(TODO "all expressions");expr} (* TODO *) +let tc_expr (_te,_ve) expr = mk_checked_expr ~ty:(TODO "all expressions") ~expr (* TODO *) let tc_var_decl : vte -> I.var_decl -> vte * O.var_decl = - fun (ve,te) {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} + fun (ve,te) var_decl -> + let vtype = (xty var_decl.vtype) in + let init = check_type (tc_expr (te,ve) var_decl.init) vtype in + let ve = shadow (unreg var_decl.var) vtype ve in + (ve,te), { + kind = var_decl.kind; + var = var_decl.var; + colon = var_decl.colon; + vtype; + setter = var_decl.setter; + init} let tc_var_decls (ve,te) var_decls = fold_map tc_var_decl (ve,te) var_decls let tc_block (te, ve : vte) (block : I.block) : vte * O.block = - let opening,instr,close = block.opening, block.instr, block.close in - (ve,te), O.{opening;instr;close} (* TODO *) + let decls,opening,instr,close = block.decls, block.opening, block.instr, block.close in + let (ve,te), decls = tc_var_decls (ve,te) (decls |> unreg |> sepseq_to_list |> map unreg) in + (ve,te), O.{decls;opening;instr;close} (* TODO *) -let tc_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_proc_decl : vte -> I.proc_decl -> O.proc_decl = + fun vte proc_decl -> + let _vte', block' = tc_block vte (unreg proc_decl.body) + in mk_proc_decl + ~kwd_procedure: proc_decl.kwd_procedure + ~kwd_is: proc_decl.kwd_is + ~var: proc_decl.var + ~param: proc_decl.param + ~body: block' let tc_fun_decl : vte -> I.fun_decl -> O.fun_decl = fun vte fun_decl -> @@ -200,29 +204,27 @@ 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.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 + FunDecl {value;_} -> shadow value.var.value (params_to_xty value.param (xty value.ret_type)) ve + | ProcDecl {value;_} -> shadow value.var.value (params_to_xty value.param Unit) ve let tc_lambda_decl (ve, te : vte) (whole : I.lambda_decl) : vte * O.lambda_decl = match whole with FunDecl {value;_} -> ((ve_lambda_decl (ve, te) whole), te), O.FunDecl (tc_fun_decl (ve, te) value) | ProcDecl {value;_} -> ((ve_lambda_decl (ve, te) whole), te), O.ProcDecl (tc_proc_decl (ve, te) value) -let tc_ast : I.ast -> O.ast = fun - {types;constants;parameter;storage;operations;lambdas;block;eof} -> +let tc_ast (ast : I.ast) : O.ast = (* te is the type environment, ve is the variable environment *) let te = SMap.empty - |> type_decls_to_tenv types in + |> type_decls_to_tenv ast.types in let ve = SMap.empty - |> (match parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty) - |> shadow "storage" @@ xty (snd storage.value) - |> shadow "operations" @@ xty (snd operations.value) + |> (match ast.parameter.value with (_,name,_,ty) -> shadow (unreg name) @@ xty ty) + |> shadow "storage" @@ xty (snd ast.storage.value) + |> shadow "operations" @@ xty (snd ast.operations.value) in - let (ve',te'), lambdas = fold_map tc_lambda_decl (ve, te) lambdas in - let (ve'', te''), block = tc_block (ve', te') (unreg block) in + let (ve',te'), lambdas = fold_map tc_lambda_decl (ve, te) ast.lambdas in + let (ve'', te''), block = tc_block (ve', te') (unreg ast.block) in let _ve'' = ve'' in (* not needed anymore *) let _te'' = te'' in (* not needed anymore *) mk_ast ~lambdas ~block - *)