From 40377a80dfab320bd2ef0af09e5d752350c9cb1d Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 18:13:09 +0100 Subject: [PATCH 1/8] Threaded 'a parameter everywhere --- AST.ml | 1108 ++++++++++++------------------------------------- AST.mli | 497 ++++++++++++---------- ParserMain.ml | 2 +- Print.ml | 573 +++++++++++++++++++++++++ Print.mli | 5 + typecheck.ml | 116 +++--- 6 files changed, 1189 insertions(+), 1112 deletions(-) create mode 100644 Print.ml create mode 100644 Print.mli diff --git a/AST.ml b/AST.ml index 7726673f9..c9596c183 100644 --- a/AST.ml +++ b/AST.ml @@ -113,12 +113,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 *) @@ -142,229 +142,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 @@ -372,46 +372,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; +and 'a map_lookup = { + map_name : 'a variable; selector : dot; - index : expr brackets + 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 @@ -421,13 +421,13 @@ 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 *) @@ -513,647 +513,77 @@ let local_decl_to_region = function (* Printing the tokens with their source regions *) -type visitor = { - ass_instr : ass_instr -> unit; - bind_to : (region * variable) option -> unit; - block : block reg -> unit; +type 'a visitor = { + ass_instr : 'a ass_instr -> unit; + bind_to : (region * 'a variable) option -> unit; + block : 'a block reg -> unit; bytes : (string * MBytes.t) reg -> 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; + 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 option -> 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; + 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 : 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; + 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; nsepseq : 'a.string -> ('a -> unit) -> ('a, region) nsepseq -> 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; + 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; sepseq : 'a.string -> ('a -> unit) -> ('a, region) sepseq -> 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; + 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; string : string reg -> unit; - sugar : (core_pattern, region) sepseq brackets -> unit; - sum_type : (variant, region) nsepseq reg -> unit; + sugar : ('a core_pattern, region) sepseq brackets -> unit; + sum_type : ('a variant, region) nsepseq reg -> unit; terminator : semi option -> unit; token : region -> string -> 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 + 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 } - -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 e8a812ec7..3505f44d2 100644 --- a/AST.mli +++ b/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 +} diff --git a/ParserMain.ml b/ParserMain.ml index 0081d3c87..0c940bfb6 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 AST.print_tokens ast + then Print.print_tokens ast with Lexer.Error err -> close_all (); diff --git a/Print.ml b/Print.ml new file mode 100644 index 000000000..50f5e19dc --- /dev/null +++ b/Print.ml @@ -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 ()) diff --git a/Print.mli b/Print.mli new file mode 100644 index 000000000..66fae6dfa --- /dev/null +++ b/Print.mli @@ -0,0 +1,5 @@ +(* Printing *) + +open AST + +val print_tokens : t -> unit diff --git a/typecheck.ml b/typecheck.ml index 99037d0bb..b768a9949 100644 --- a/typecheck.ml +++ b/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 + *) From fb85ea1f18e7f29460f62deaa1abc0d2e5d37d1a Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 18:16:21 +0100 Subject: [PATCH 2/8] Renamed the extensibility type parameter to 'x so that it can easily be grepped for. Review this commit with: git diff --color-words=. --- AST.ml | 450 ++++++++++++++++++++++++++--------------------------- AST.mli | 464 +++++++++++++++++++++++++++---------------------------- Print.ml | 132 ++++++++-------- 3 files changed, 523 insertions(+), 523 deletions(-) diff --git a/AST.ml b/AST.ml index c9596c183..940b562c4 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 'x variable = string reg +type 'x fun_name = string reg +type 'x type_name = string reg +type 'x field_name = string reg +type 'x map_name = string reg +type 'x constr = string reg (* Comma-separated non-empty lists *) @@ -144,227 +144,227 @@ type 'a braces = (lbrace * 'a * rbrace) reg 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; +and 'x ast = { + types : 'x type_decl reg list; + constants : 'x const_decl reg list; + parameter : 'x parameter_decl reg; + storage : 'x storage_decl reg; + operations : 'x operations_decl reg; + lambdas : 'x lambda_decl list; + block : 'x block reg; eof : eof } -and 'a parameter_decl = { +and 'x parameter_decl = { kwd_parameter : kwd_parameter; - name : 'a variable; + name : 'x variable; colon : colon; - param_type : 'a type_expr; + param_type : 'x type_expr; terminator : semi option } -and 'a storage_decl = { +and 'x storage_decl = { kwd_storage : kwd_storage; - store_type : 'a type_expr; + store_type : 'x type_expr; terminator : semi option } -and 'a operations_decl = { +and 'x operations_decl = { kwd_operations : kwd_operations; - op_type : 'a type_expr; + op_type : 'x type_expr; terminator : semi option } (* Type declarations *) -and 'a type_decl = { +and 'x type_decl = { kwd_type : kwd_type; - name : 'a type_name; + name : 'x type_name; kwd_is : kwd_is; - type_expr : 'a type_expr; + type_expr : 'x 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 'x type_expr = + Prod of 'x cartesian +| Sum of ('x variant, vbar) nsepseq reg +| Record of 'x record_type +| TypeApp of ('x type_name * 'x type_tuple) reg +| ParType of 'x type_expr par +| TAlias of 'x variable -and 'a cartesian = ('a type_expr, times) nsepseq reg +and 'x cartesian = ('x type_expr, times) nsepseq reg -and 'a variant = ('a constr * kwd_of * 'a cartesian) reg +and 'x variant = ('x constr * kwd_of * 'x cartesian) reg -and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg +and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg -and 'a field_decls = ('a field_decl, semi) nsepseq +and 'x field_decls = ('x field_decl, semi) nsepseq -and 'a field_decl = ('a variable * colon * 'a type_expr) reg +and 'x field_decl = ('x variable * colon * 'x type_expr) reg -and 'a type_tuple = ('a type_name, comma) nsepseq par +and 'x type_tuple = ('x 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 'x lambda_decl = + FunDecl of 'x fun_decl reg +| ProcDecl of 'x proc_decl reg -and 'a fun_decl = { +and 'x fun_decl = { kwd_function : kwd_function; - name : 'a variable; - param : 'a parameters; + name : 'x variable; + param : 'x parameters; colon : colon; - ret_type : 'a type_expr; + ret_type : 'x type_expr; kwd_is : kwd_is; - local_decls : 'a local_decl list; - block : 'a block reg; + local_decls : 'x local_decl list; + block : 'x block reg; kwd_with : kwd_with; - return : 'a expr; + return : 'x expr; terminator : semi option } -and 'a proc_decl = { +and 'x proc_decl = { kwd_procedure : kwd_procedure; - name : 'a variable; - param : 'a parameters; + name : 'x variable; + param : 'x parameters; kwd_is : kwd_is; - local_decls : 'a local_decl list; - block : 'a block reg; + local_decls : 'x local_decl list; + block : 'x block reg; terminator : semi option } -and 'a parameters = ('a param_decl, semi) nsepseq par +and 'x parameters = ('x param_decl, semi) nsepseq par -and 'a param_decl = - ParamConst of 'a param_const -| ParamVar of 'a param_var +and 'x param_decl = + ParamConst of 'x param_const +| ParamVar of 'x param_var -and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg +and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg -and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg +and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg -and 'a block = { +and 'x block = { opening : kwd_begin; - instr : 'a instructions; + instr : 'x 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 'x local_decl = + LocalLam of 'x lambda_decl +| LocalConst of 'x const_decl reg +| LocalVar of 'x var_decl reg -and 'a const_decl = { +and 'x const_decl = { kwd_const : kwd_const; - name : 'a variable; + name : 'x variable; colon : colon; - vtype : 'a type_expr; + vtype : 'x type_expr; equal : equal; - init : 'a expr; + init : 'x expr; terminator : semi option } -and 'a var_decl = { +and 'x var_decl = { kwd_var : kwd_var; - name : 'a variable; + name : 'x variable; colon : colon; - vtype : 'a type_expr; + vtype : 'x type_expr; ass : ass; - init : 'a expr; + init : 'x expr; terminator : semi option } -and 'a instructions = ('a instruction, semi) nsepseq reg +and 'x instructions = ('x instruction, semi) nsepseq reg -and 'a instruction = - Single of 'a single_instr -| Block of 'a block reg +and 'x instruction = + Single of 'x single_instr +| Block of 'x 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 'x single_instr = + Cond of 'x conditional reg +| Match of 'x match_instr reg +| Ass of 'x ass_instr +| Loop of 'x loop +| ProcCall of 'x fun_call | Null of kwd_null -| Fail of (kwd_fail * 'a expr) reg +| Fail of (kwd_fail * 'x expr) reg -and 'a conditional = { +and 'x conditional = { kwd_if : kwd_if; - test : 'a expr; + test : 'x expr; kwd_then : kwd_then; - ifso : 'a instruction; + ifso : 'x instruction; kwd_else : kwd_else; - ifnot : 'a instruction + ifnot : 'x instruction } -and 'a match_instr = { +and 'x match_instr = { kwd_match : kwd_match; - expr : 'a expr; + expr : 'x expr; kwd_with : kwd_with; lead_vbar : vbar option; - cases : 'a cases; + cases : 'x cases; kwd_end : kwd_end } -and 'a cases = ('a case, vbar) nsepseq reg +and 'x cases = ('x case, vbar) nsepseq reg -and 'a case = ('a pattern * arrow * 'a instruction) reg +and 'x case = ('x pattern * arrow * 'x instruction) reg -and 'a ass_instr = ('a variable * ass * 'a expr) reg +and 'x ass_instr = ('x variable * ass * 'x expr) reg -and 'a loop = - While of 'a while_loop -| For of 'a for_loop +and 'x loop = + While of 'x while_loop +| For of 'x for_loop -and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg +and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg -and 'a for_loop = - ForInt of 'a for_int reg -| ForCollect of 'a for_collect reg +and 'x for_loop = + ForInt of 'x for_int reg +| ForCollect of 'x for_collect reg -and 'a for_int = { +and 'x for_int = { kwd_for : kwd_for; - ass : 'a ass_instr; + ass : 'x ass_instr; down : kwd_down option; kwd_to : kwd_to; - bound : 'a expr; - step : (kwd_step * 'a expr) option; - block : 'a block reg + bound : 'x expr; + step : (kwd_step * 'x expr) option; + block : 'x block reg } -and 'a for_collect = { +and 'x for_collect = { kwd_for : kwd_for; - var : 'a variable; - bind_to : (arrow * 'a variable) option; + var : 'x variable; + bind_to : (arrow * 'x variable) option; kwd_in : kwd_in; - expr : 'a expr; - block : 'a block reg + expr : 'x expr; + block : 'x 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 'x expr = + Or of ('x expr * bool_or * 'x expr) reg +| And of ('x expr * bool_and * 'x expr) reg +| Lt of ('x expr * lt * 'x expr) reg +| Leq of ('x expr * leq * 'x expr) reg +| Gt of ('x expr * gt * 'x expr) reg +| Geq of ('x expr * geq * 'x expr) reg +| Equal of ('x expr * equal * 'x expr) reg +| Neq of ('x expr * neq * 'x expr) reg +| Cat of ('x expr * cat * 'x expr) reg +| Cons of ('x expr * cons * 'x expr) reg +| Add of ('x expr * plus * 'x expr) reg +| Sub of ('x expr * minus * 'x expr) reg +| Mult of ('x expr * times * 'x expr) reg +| Div of ('x expr * slash * 'x expr) reg +| Mod of ('x expr * kwd_mod * 'x expr) reg +| Neg of (minus * 'x expr) reg +| Not of (kwd_not * 'x 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 'x tuple +| List of ('x expr, comma) nsepseq brackets +| EmptyList of 'x empty_list +| Set of ('x expr, comma) nsepseq braces +| EmptySet of 'x empty_set +| NoneExpr of 'x none_expr +| FunCall of 'x fun_call +| ConstrApp of 'x constr_app +| SomeApp of (c_Some * 'x arguments) reg +| MapLookUp of 'x map_lookup reg +| ParExpr of 'x expr par -and 'a tuple = ('a expr, comma) nsepseq par +and 'x tuple = ('x expr, comma) nsepseq par -and 'a empty_list = - (lbracket * rbracket * colon * 'a type_expr) par +and 'x empty_list = + (lbracket * rbracket * colon * 'x type_expr) par -and 'a empty_set = - (lbrace * rbrace * colon * 'a type_expr) par +and 'x empty_set = + (lbrace * rbrace * colon * 'x type_expr) par -and 'a none_expr = - (c_None * colon * 'a type_expr) par +and 'x none_expr = + (c_None * colon * 'x type_expr) par -and 'a fun_call = ('a fun_name * 'a arguments) reg +and 'x fun_call = ('x fun_name * 'x arguments) reg -and 'a arguments = 'a tuple +and 'x arguments = 'x tuple -and 'a constr_app = ('a constr * 'a arguments) reg +and 'x constr_app = ('x constr * 'x arguments) reg -and 'a map_lookup = { - map_name : 'a variable; +and 'x map_lookup = { + map_name : 'x variable; selector : dot; - index : 'a expr brackets + index : 'x expr brackets } (* Patterns *) -and 'a pattern = ('a core_pattern, cons) nsepseq reg +and 'x pattern = ('x core_pattern, cons) nsepseq reg -and 'a core_pattern = +and 'x 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 * 'x core_pattern par) reg +| PList of 'x list_pattern +| PTuple of ('x 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 'x list_pattern = + Sugar of ('x core_pattern, comma) sepseq brackets +| Raw of ('x core_pattern * cons * 'x pattern) par (* Projecting regions *) @@ -513,77 +513,77 @@ 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 'x visitor = { + ass_instr : 'x ass_instr -> unit; + bind_to : (region * 'x variable) option -> unit; + block : 'x 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 : 'x cartesian -> unit; + case : 'x case -> unit; + cases : 'x cases -> unit; + conditional : 'x conditional -> unit; + const_decl : 'x const_decl reg -> unit; + constr : 'x constr -> unit; + constr_app : 'x constr_app -> unit; + core_pattern : 'x 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 : 'x empty_list -> unit; + empty_set : 'x empty_set -> unit; + expr : 'x expr -> unit; + fail : (kwd_fail * 'x expr) -> unit; + field_decl : 'x field_decl -> unit; + field_decls : 'x field_decls -> unit; + for_collect : 'x for_collect reg -> unit; + for_int : 'x for_int reg -> unit; + for_loop : 'x for_loop -> unit; + fun_call : 'x fun_call -> unit; + fun_decl : 'x fun_decl reg -> unit; + instruction : 'x instruction -> unit; + instructions : 'x 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 : 'x lambda_decl -> unit; + list : ('x expr, region) nsepseq brackets -> unit; + list_pattern : 'x list_pattern -> unit; + loop : 'x loop -> unit; + map_lookup : 'x map_lookup reg -> unit; + match_instr : 'x match_instr -> unit; + none_expr : 'x 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 : 'x operations_decl reg -> unit; + par_expr : 'x expr par -> unit; + par_type : 'x type_expr par -> unit; + param_decl : 'x param_decl -> unit; + parameter_decl : 'x parameter_decl reg -> unit; + parameters : 'x parameters -> unit; + param_const : 'x param_const -> unit; + param_var : 'x param_var -> unit; + pattern : 'x pattern -> unit; + patterns : 'x core_pattern par -> unit; + proc_decl : 'x proc_decl reg -> unit; + psome : (region * 'x core_pattern par) reg -> unit; + ptuple : ('x core_pattern, region) nsepseq par -> unit; + raw : ('x core_pattern * region * 'x pattern) par -> unit; + record_type : 'x 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 : ('x expr, region) nsepseq braces -> unit; + single_instr : 'x single_instr -> unit; + some_app : (region * 'x arguments) reg -> unit; + step : (region * 'x expr) option -> unit; + storage_decl : 'x 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 : ('x core_pattern, region) sepseq brackets -> unit; + sum_type : ('x 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 : 'x arguments -> unit; + type_app : ('x type_name * 'x type_tuple) reg -> unit; + type_decl : 'x type_decl reg -> unit; + type_expr : 'x type_expr -> unit; + type_tuple : 'x type_tuple -> unit; + local_decl : 'x local_decl -> unit; + local_decls : 'x local_decl list -> unit; + var : 'x variable -> unit; + var_decl : 'x var_decl reg -> unit; + variant : 'x variant -> unit; + while_loop : 'x while_loop -> unit } diff --git a/AST.mli b/AST.mli index 3505f44d2..cb6fbcd2b 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 'x variable = string reg +type 'x fun_name = string reg +type 'x type_name = string reg +type 'x field_name = string reg +type 'x map_name = string reg +type 'x constr = string reg (* Comma-separated non-empty lists *) @@ -128,227 +128,227 @@ type 'a braces = (lbrace * 'a * rbrace) reg 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; +and 'x ast = { + types : 'x type_decl reg list; + constants : 'x const_decl reg list; + parameter : 'x parameter_decl reg; + storage : 'x storage_decl reg; + operations : 'x operations_decl reg; + lambdas : 'x lambda_decl list; + block : 'x block reg; eof : eof } -and 'a parameter_decl = { +and 'x parameter_decl = { kwd_parameter : kwd_parameter; - name : 'a variable; + name : 'x variable; colon : colon; - param_type : 'a type_expr; + param_type : 'x type_expr; terminator : semi option } -and 'a storage_decl = { +and 'x storage_decl = { kwd_storage : kwd_storage; - store_type : 'a type_expr; + store_type : 'x type_expr; terminator : semi option } -and 'a operations_decl = { +and 'x operations_decl = { kwd_operations : kwd_operations; - op_type : 'a type_expr; + op_type : 'x type_expr; terminator : semi option } (* Type declarations *) -and 'a type_decl = { +and 'x type_decl = { kwd_type : kwd_type; - name : 'a type_name; + name : 'x type_name; kwd_is : kwd_is; - type_expr : 'a type_expr; + type_expr : 'x 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 'x type_expr = + Prod of 'x cartesian +| Sum of ('x variant, vbar) nsepseq reg +| Record of 'x record_type +| TypeApp of ('x type_name * 'x type_tuple) reg +| ParType of 'x type_expr par +| TAlias of 'x variable -and 'a cartesian = ('a type_expr, times) nsepseq reg +and 'x cartesian = ('x type_expr, times) nsepseq reg -and 'a variant = ('a constr * kwd_of * 'a cartesian) reg +and 'x variant = ('x constr * kwd_of * 'x cartesian) reg -and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg +and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg -and 'a field_decls = ('a field_decl, semi) nsepseq +and 'x field_decls = ('x field_decl, semi) nsepseq -and 'a field_decl = ('a variable * colon * 'a type_expr) reg +and 'x field_decl = ('x variable * colon * 'x type_expr) reg -and 'a type_tuple = ('a type_name, comma) nsepseq par +and 'x type_tuple = ('x 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 'x lambda_decl = + FunDecl of 'x fun_decl reg +| ProcDecl of 'x proc_decl reg -and 'a fun_decl = { +and 'x fun_decl = { kwd_function : kwd_function; - name : 'a variable; - param : 'a parameters; + name : 'x variable; + param : 'x parameters; colon : colon; - ret_type : 'a type_expr; + ret_type : 'x type_expr; kwd_is : kwd_is; - local_decls : 'a local_decl list; - block : 'a block reg; + local_decls : 'x local_decl list; + block : 'x block reg; kwd_with : kwd_with; - return : 'a expr; + return : 'x expr; terminator : semi option } -and 'a proc_decl = { +and 'x proc_decl = { kwd_procedure : kwd_procedure; - name : 'a variable; - param : 'a parameters; + name : 'x variable; + param : 'x parameters; kwd_is : kwd_is; - local_decls : 'a local_decl list; - block : 'a block reg; + local_decls : 'x local_decl list; + block : 'x block reg; terminator : semi option } -and 'a parameters = ('a param_decl, semi) nsepseq par +and 'x parameters = ('x param_decl, semi) nsepseq par -and 'a param_decl = - ParamConst of 'a param_const -| ParamVar of 'a param_var +and 'x param_decl = + ParamConst of 'x param_const +| ParamVar of 'x param_var -and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg +and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg -and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg +and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg -and 'a block = { +and 'x block = { opening : kwd_begin; - instr : 'a instructions; + instr : 'x 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 'x local_decl = + LocalLam of 'x lambda_decl +| LocalConst of 'x const_decl reg +| LocalVar of 'x var_decl reg -and 'a const_decl = { +and 'x const_decl = { kwd_const : kwd_const; - name : 'a variable; + name : 'x variable; colon : colon; - vtype : 'a type_expr; + vtype : 'x type_expr; equal : equal; - init : 'a expr; + init : 'x expr; terminator : semi option } -and 'a var_decl = { +and 'x var_decl = { kwd_var : kwd_var; - name : 'a variable; + name : 'x variable; colon : colon; - vtype : 'a type_expr; + vtype : 'x type_expr; ass : ass; - init : 'a expr; + init : 'x expr; terminator : semi option } -and 'a instructions = ('a instruction, semi) nsepseq reg +and 'x instructions = ('x instruction, semi) nsepseq reg -and 'a instruction = - Single of 'a single_instr -| Block of 'a block reg +and 'x instruction = + Single of 'x single_instr +| Block of 'x 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 'x single_instr = + Cond of 'x conditional reg +| Match of 'x match_instr reg +| Ass of 'x ass_instr +| Loop of 'x loop +| ProcCall of 'x fun_call | Null of kwd_null -| Fail of (kwd_fail * 'a expr) reg +| Fail of (kwd_fail * 'x expr) reg -and 'a conditional = { +and 'x conditional = { kwd_if : kwd_if; - test : 'a expr; + test : 'x expr; kwd_then : kwd_then; - ifso : 'a instruction; + ifso : 'x instruction; kwd_else : kwd_else; - ifnot : 'a instruction + ifnot : 'x instruction } -and 'a match_instr = { +and 'x match_instr = { kwd_match : kwd_match; - expr : 'a expr; + expr : 'x expr; kwd_with : kwd_with; lead_vbar : vbar option; - cases : 'a cases; + cases : 'x cases; kwd_end : kwd_end } -and 'a cases = ('a case, vbar) nsepseq reg +and 'x cases = ('x case, vbar) nsepseq reg -and 'a case = ('a pattern * arrow * 'a instruction) reg +and 'x case = ('x pattern * arrow * 'x instruction) reg -and 'a ass_instr = ('a variable * ass * 'a expr) reg +and 'x ass_instr = ('x variable * ass * 'x expr) reg -and 'a loop = - While of 'a while_loop -| For of 'a for_loop +and 'x loop = + While of 'x while_loop +| For of 'x for_loop -and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg +and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg -and 'a for_loop = - ForInt of 'a for_int reg -| ForCollect of 'a for_collect reg +and 'x for_loop = + ForInt of 'x for_int reg +| ForCollect of 'x for_collect reg -and 'a for_int = { +and 'x for_int = { kwd_for : kwd_for; - ass : 'a ass_instr; + ass : 'x ass_instr; down : kwd_down option; kwd_to : kwd_to; - bound : 'a expr; - step : (kwd_step * 'a expr) option; - block : 'a block reg + bound : 'x expr; + step : (kwd_step * 'x expr) option; + block : 'x block reg } -and 'a for_collect = { +and 'x for_collect = { kwd_for : kwd_for; - var : 'a variable; - bind_to : (arrow * 'a variable) option; + var : 'x variable; + bind_to : (arrow * 'x variable) option; kwd_in : kwd_in; - expr : 'a expr; - block : 'a block reg + expr : 'x expr; + block : 'x 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 'x expr = + Or of ('x expr * bool_or * 'x expr) reg +| And of ('x expr * bool_and * 'x expr) reg +| Lt of ('x expr * lt * 'x expr) reg +| Leq of ('x expr * leq * 'x expr) reg +| Gt of ('x expr * gt * 'x expr) reg +| Geq of ('x expr * geq * 'x expr) reg +| Equal of ('x expr * equal * 'x expr) reg +| Neq of ('x expr * neq * 'x expr) reg +| Cat of ('x expr * cat * 'x expr) reg +| Cons of ('x expr * cons * 'x expr) reg +| Add of ('x expr * plus * 'x expr) reg +| Sub of ('x expr * minus * 'x expr) reg +| Mult of ('x expr * times * 'x expr) reg +| Div of ('x expr * slash * 'x expr) reg +| Mod of ('x expr * kwd_mod * 'x expr) reg +| Neg of (minus * 'x expr) reg +| Not of (kwd_not * 'x 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 'x tuple +| List of ('x expr, comma) nsepseq brackets +| EmptyList of 'x empty_list +| Set of ('x expr, comma) nsepseq braces +| EmptySet of 'x empty_set +| NoneExpr of 'x none_expr +| FunCall of 'x fun_call +| ConstrApp of 'x constr_app +| SomeApp of (c_Some * 'x arguments) reg +| MapLookUp of 'x map_lookup reg +| ParExpr of 'x expr par -and 'a tuple = ('a expr, comma) nsepseq par +and 'x tuple = ('x expr, comma) nsepseq par -and 'a empty_list = - (lbracket * rbracket * colon * 'a type_expr) par +and 'x empty_list = + (lbracket * rbracket * colon * 'x type_expr) par -and 'a empty_set = - (lbrace * rbrace * colon * 'a type_expr) par +and 'x empty_set = + (lbrace * rbrace * colon * 'x type_expr) par -and 'a none_expr = - (c_None * colon * 'a type_expr) par +and 'x none_expr = + (c_None * colon * 'x type_expr) par -and 'a fun_call = ('a fun_name * 'a arguments) reg +and 'x fun_call = ('x fun_name * 'x arguments) reg -and 'a arguments = 'a tuple +and 'x arguments = 'x tuple -and 'a constr_app = ('a constr * 'a arguments) reg +and 'x constr_app = ('x constr * 'x arguments) reg -and 'a map_lookup = { - map_name : 'a variable; +and 'x map_lookup = { + map_name : 'x variable; selector : dot; - index : 'a expr brackets + index : 'x expr brackets } (* Patterns *) -and 'a pattern = ('a core_pattern, cons) nsepseq reg +and 'x pattern = ('x core_pattern, cons) nsepseq reg -and 'a core_pattern = +and 'x core_pattern = PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -405,97 +405,97 @@ 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 * 'x core_pattern par) reg +| PList of 'x list_pattern +| PTuple of ('x 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 'x list_pattern = + Sugar of ('x core_pattern, comma) sepseq brackets +| Raw of ('x core_pattern * cons * 'x pattern) par (* Projecting regions *) -val type_expr_to_region : 'a type_expr -> Region.t +val type_expr_to_region : 'x type_expr -> Region.t -val expr_to_region : 'a expr -> Region.t +val expr_to_region : 'x expr -> Region.t -val instr_to_region : 'a instruction -> Region.t +val instr_to_region : 'x instruction -> Region.t -val core_pattern_to_region : 'a core_pattern -> Region.t +val core_pattern_to_region : 'x core_pattern -> Region.t -val local_decl_to_region : 'a local_decl -> Region.t +val local_decl_to_region : 'x 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; +type 'x visitor = { + ass_instr : 'x ass_instr -> unit; + bind_to : (Region.t * 'x variable) option -> unit; + block : 'x 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 : 'x cartesian -> unit; + case : 'x case -> unit; + cases : 'x cases -> unit; + conditional : 'x conditional -> unit; + const_decl : 'x const_decl reg -> unit; + constr : 'x constr -> unit; + constr_app : 'x constr_app -> unit; + core_pattern : 'x 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; + empty_list : 'x empty_list -> unit; + empty_set : 'x empty_set -> unit; + expr : 'x expr -> unit; + fail : (kwd_fail * 'x expr) -> unit; + field_decl : 'x field_decl -> unit; + field_decls : 'x field_decls -> unit; + for_collect : 'x for_collect reg -> unit; + for_int : 'x for_int reg -> unit; + for_loop : 'x for_loop -> unit; + fun_call : 'x fun_call -> unit; + fun_decl : 'x fun_decl reg -> unit; + instruction : 'x instruction -> unit; + instructions : 'x 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; + lambda_decl : 'x lambda_decl -> unit; + list : ('x expr, Region.t) nsepseq brackets -> unit; + list_pattern : 'x list_pattern -> unit; + loop : 'x loop -> unit; + map_lookup : 'x map_lookup reg -> unit; + match_instr : 'x match_instr -> unit; + none_expr : 'x none_expr -> unit; + nsepseq : 'x.string -> ('x -> unit) -> ('x, Region.t) nsepseq -> unit; + operations_decl : 'x operations_decl reg -> unit; + par_expr : 'x expr par -> unit; + par_type : 'x type_expr par -> unit; + param_decl : 'x param_decl -> unit; + parameter_decl : 'x parameter_decl reg -> unit; + parameters : 'x parameters -> unit; + param_const : 'x param_const -> unit; + param_var : 'x param_var -> unit; + pattern : 'x pattern -> unit; + patterns : 'x core_pattern par -> unit; + proc_decl : 'x proc_decl reg -> unit; + psome : (Region.t * 'x core_pattern par) reg -> unit; + ptuple : ('x core_pattern, Region.t) nsepseq par -> unit; + raw : ('x core_pattern * Region.t * 'x pattern) par -> unit; + record_type : 'x record_type -> unit; + sepseq : 'x.string -> ('x -> unit) -> ('x, Region.t) sepseq -> unit; + set : ('x expr, Region.t) nsepseq braces -> unit; + single_instr : 'x single_instr -> unit; + some_app : (Region.t * 'x arguments) reg -> unit; + step : (Region.t * 'x expr) option -> unit; + storage_decl : 'x 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; + sugar : ('x core_pattern, Region.t) sepseq brackets -> unit; + sum_type : ('x 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 + tuple : 'x arguments -> unit; + type_app : ('x type_name * 'x type_tuple) reg -> unit; + type_decl : 'x type_decl reg -> unit; + type_expr : 'x type_expr -> unit; + type_tuple : 'x type_tuple -> unit; + local_decl : 'x local_decl -> unit; + local_decls : 'x local_decl list -> unit; + var : 'x variable -> unit; + var_decl : 'x var_decl reg -> unit; + variant : 'x variant -> unit; + while_loop : 'x while_loop -> unit } diff --git a/Print.ml b/Print.ml index 50f5e19dc..c41da7f0a 100644 --- a/Print.ml +++ b/Print.ml @@ -47,7 +47,7 @@ and print_int _visitor {region; value = lexeme, abstract} = (* Main printing function *) -and print_tokens (v: 'a visitor) ast = +and print_tokens (v: 'x visitor) ast = List.iter v.type_decl ast.types; v.parameter_decl ast.parameter; v.storage_decl ast.storage; @@ -56,31 +56,31 @@ and print_tokens (v: 'a visitor) ast = v.block ast.block; v.token ast.eof "EOF" -and print_parameter_decl (v: 'a visitor) {value=node; _} = +and print_parameter_decl (v: 'x 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; _} = +and print_storage_decl (v: 'x 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; _} = +and print_operations_decl (v: 'x 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; _} = +and print_type_decl (v: 'x 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 +and print_type_expr (v: 'x visitor) = function Prod cartesian -> v.cartesian cartesian | Sum sum_type -> v.sum_type sum_type | Record record_type -> v.record_type record_type @@ -88,55 +88,55 @@ and print_type_expr (v: 'a visitor) = function | ParType par_type -> v.par_type par_type | TAlias type_alias -> v.var type_alias -and print_cartesian (v: 'a visitor) {value=sequence; _} = +and print_cartesian (v: 'x visitor) {value=sequence; _} = v.nsepseq "*" v.type_expr sequence -and print_variant (v: 'a visitor) {value=node; _} = +and print_variant (v: 'x 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; _} = +and print_sum_type (v: 'x visitor) {value=sequence; _} = v.nsepseq "|" v.variant sequence -and print_record_type (v: 'a visitor) {value=node; _} = +and print_record_type (v: 'x 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; _} = +and print_type_app (v: 'x 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; _} = +and print_par_type (v: 'x 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 = +and print_field_decls (v: 'x visitor) sequence = v.nsepseq ";" v.field_decl sequence -and print_field_decl (v: 'a visitor) {value=node; _} = +and print_field_decl (v: 'x 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; _} = +and print_type_tuple (v: 'x 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 +and print_lambda_decl (v: 'x 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; _} = +and print_fun_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_function "function"; v.var node.name; v.parameters node.param; @@ -149,7 +149,7 @@ and print_fun_decl (v: 'a visitor) {value=node; _} = v.expr node.return; v.terminator node.terminator -and print_proc_decl (v: 'a visitor) {value=node; _} = +and print_proc_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_procedure "procedure"; v.var node.name; v.parameters node.param; @@ -158,45 +158,45 @@ and print_proc_decl (v: 'a visitor) {value=node; _} = v.block node.block; v.terminator node.terminator -and print_parameters (v: 'a visitor) {value=node; _} = +and print_parameters (v: 'x 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 +and print_param_decl (v: 'x 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; _} = +and print_param_const (v: 'x 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; _} = +and print_param_var (v: 'x 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; _} = +and print_block (v: 'x 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 = +and print_local_decls (v: 'x visitor) sequence = List.iter v.local_decl sequence -and print_local_decl (v: 'a visitor) = function +and print_local_decl (v: 'x 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; _} = +and print_const_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_const "const"; v.var node.name; v.token node.colon ":"; @@ -205,7 +205,7 @@ and print_const_decl (v: 'a visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_var_decl (v: 'a visitor) {value=node; _} = +and print_var_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_var "var"; v.var node.name; v.token node.colon ":"; @@ -214,14 +214,14 @@ and print_var_decl (v: 'a visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_instructions (v: 'a visitor) {value=sequence; _} = +and print_instructions (v: 'x visitor) {value=sequence; _} = v.nsepseq ";" v.instruction sequence -and print_instruction (v: 'a visitor) = function +and print_instruction (v: 'x visitor) = function Single instr -> v.single_instr instr | Block block -> v.block block -and print_single_instr (v: 'a visitor) = function +and print_single_instr (v: 'x visitor) = function Cond {value; _} -> v.conditional value | Match {value; _} -> v.match_instr value | Ass instr -> v.ass_instr instr @@ -230,11 +230,11 @@ and print_single_instr (v: 'a visitor) = function | Null kwd_null -> v.token kwd_null "null" | Fail {value; _} -> v.fail value -and print_fail (v: 'a visitor) (kwd_fail, expr) = +and print_fail (v: 'x visitor) (kwd_fail, expr) = v.token kwd_fail "fail"; v.expr expr -and print_conditional (v: 'a visitor) node = +and print_conditional (v: 'x visitor) node = v.token node.kwd_if "if"; v.expr node.test; v.token node.kwd_then "then"; @@ -242,43 +242,43 @@ and print_conditional (v: 'a visitor) node = v.token node.kwd_else "else"; v.instruction node.ifnot -and print_match_instr (v: 'a visitor) node = +and print_match_instr (v: 'x 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; _} = +and print_cases (v: 'x visitor) {value=sequence; _} = v.nsepseq "|" v.case sequence -and print_case (v: 'a visitor) {value=node; _} = +and print_case (v: 'x 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; _} = +and print_ass_instr (v: 'x 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 +and print_loop (v: 'x 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; _} = +and print_while_loop (v: 'x 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 +and print_for_loop (v: 'x 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) = +and print_for_int (v: 'x visitor) ({value=node; _} : 'x for_int reg) = v.token node.kwd_for "for"; v.ass_instr node.ass; v.down node.down; @@ -287,17 +287,17 @@ and print_for_int (v: 'a visitor) ({value=node; _} : 'a for_int reg) = v.step node.step; v.block node.block -and print_down (v: 'a visitor) = function +and print_down (v: 'x visitor) = function Some kwd_down -> v.token kwd_down "down" | None -> () -and print_step (v: 'a visitor) = function +and print_step (v: 'x 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) = +and print_for_collect (v: 'x visitor) ({value=node; _} : 'x for_collect reg) = v.token node.kwd_for "for"; v.var node.var; v.bind_to node.bind_to; @@ -305,13 +305,13 @@ and print_for_collect (v: 'a visitor) ({value=node; _} : 'a for_collect reg) = v.expr node.expr; v.block node.block -and print_bind_to (v: 'a visitor) = function +and print_bind_to (v: 'x visitor) = function Some (arrow, variable) -> v.token arrow "->"; v.var variable | None -> () -and print_expr (v: 'a visitor) = function +and print_expr (v: 'x visitor) = function Or {value = expr1, bool_or, expr2; _} -> v.expr expr1; v.token bool_or "||"; v.expr expr2 | And {value = expr1, bool_and, expr2; _} -> @@ -365,19 +365,19 @@ and print_expr (v: 'a visitor) = function | MapLookUp lookup -> v.map_lookup lookup | ParExpr pexpr -> v.par_expr pexpr -and print_tuple (v: 'a visitor) {value=node; _} = +and print_tuple (v: 'x 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; _} = +and print_list (v: 'x 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; _} = +and print_empty_list (v: 'x visitor) {value=node; _} = let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in v.token lpar "("; v.token lbracket "["; @@ -386,13 +386,13 @@ and print_empty_list (v: 'a visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_set (v: 'a visitor) {value=node; _} = +and print_set (v: 'x 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; _} = +and print_empty_set (v: 'x visitor) {value=node; _} = let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in v.token lpar "("; v.token lbrace "{"; @@ -401,7 +401,7 @@ and print_empty_set (v: 'a visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_none_expr (v: 'a visitor) {value=node; _} = +and print_none_expr (v: 'x visitor) {value=node; _} = let lpar, (c_None, colon, type_expr), rpar = node in v.token lpar "("; v.token c_None "None"; @@ -409,22 +409,22 @@ and print_none_expr (v: 'a visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_fun_call (v: 'a visitor) {value=node; _} = +and print_fun_call (v: 'x 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; _} = +and print_constr_app (v: 'x visitor) {value=node; _} = let constr, arguments = node in v.constr constr; v.tuple arguments -and print_some_app (v: 'a visitor) {value=node; _} = +and print_some_app (v: 'x 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; _} = +and print_map_lookup (v: 'x visitor) {value=node; _} = let {value = lbracket, expr, rbracket; _} = node.index in v.var node.map_name; v.token node.selector "."; @@ -432,16 +432,16 @@ and print_map_lookup (v: 'a visitor) {value=node; _} = v.expr expr; v.token rbracket "]" -and print_par_expr (v: 'a visitor) {value=node; _} = +and print_par_expr (v: 'x 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; _} = +and print_pattern (v: 'x visitor) {value=sequence; _} = v.nsepseq "<:" v.core_pattern sequence -and print_core_pattern (v: 'a visitor) = function +and print_core_pattern (v: 'x visitor) = function PVar var -> v.var var | PWild wild -> v.token wild "_" | PInt i -> v.int i @@ -455,28 +455,28 @@ and print_core_pattern (v: 'a visitor) = function | PList pattern -> v.list_pattern pattern | PTuple ptuple -> v.ptuple ptuple -and print_psome (v: 'a visitor) {value=node; _} = +and print_psome (v: 'x 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; _} = +and print_patterns (v: 'x 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 +and print_list_pattern (v: 'x visitor) = function Sugar sugar -> v.sugar sugar | Raw raw -> v.raw raw -and print_sugar (v: 'a visitor) {value=node; _} = +and print_sugar (v: 'x 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; _} = +and print_raw (v: 'x visitor) {value=node; _} = let lpar, (core_pattern, cons, pattern), rpar = node in v.token lpar "("; v.core_pattern core_pattern; @@ -484,17 +484,17 @@ and print_raw (v: 'a visitor) {value=node; _} = v.pattern pattern; v.token rpar ")" -and print_ptuple (v: 'a visitor) {value=node; _} = +and print_ptuple (v: 'x 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 +and print_terminator (v: 'x visitor) = function Some semi -> v.token semi ";" | None -> () -let rec visitor () : 'a visitor = { +let rec visitor () : 'x visitor = { nsepseq = print_nsepseq; sepseq = print_sepseq; token = print_token (visitor ()); From 9b9760f052c85202cd59e7132d2649d41e54424f Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 20:37:32 +0100 Subject: [PATCH 3/8] =?UTF-8?q?WIP=E2=80=A6?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- AST.ml | 167 +++++++++++++++++++++--- AST.mli | 122 ++++++++++++++++-- Parser.mly | 12 +- ParserMain.ml | 6 +- Print.ml | 145 ++++++++++----------- Print.mli | 2 +- Typecheck2.ml | 337 +++++++++++++++++++++++++++++++++++++++++++++++++ Typecheck2.mli | 1 + typecheck.ml | 5 - 9 files changed, 688 insertions(+), 109 deletions(-) create mode 100644 Typecheck2.ml create mode 100644 Typecheck2.mli diff --git a/AST.ml b/AST.ml index 940b562c4..6f62f6e98 100644 --- a/AST.ml +++ b/AST.ml @@ -142,9 +142,45 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -type t = < ty: unit > ast +type ttrue = TTrue +type tfalse = TFalse +type ('a, 'type_expr_typecheck) gadt_if = + Present : 'a -> ('a, ttrue) gadt_if -and 'x ast = { +(* It is possible to further ensure well-typedness at the meta level + by using the following constraint: + + type ttrue = [`True] + type tfalse = [`False] + + type 'x x_sig = 'x + constraint 'x = < ty: 'ty; + type_expr_typecheck: [< `True | `False] > + + we could also use a single selector for type_expr, as long as + the fields are monotonic: + + type z = [`Z] + type 'i s = [`S of 'i] + type 'is type_level_int = [< `S of 'i | `Z] + constraint 'i = 'prev type_level_int + + type parse_phase = z + type typecheck_phase = z s + type further_phase = z s s + + type 'x x_sig = 'x + constraint 'x = < ty: 'ty; + type_expr: 'type_expr > + + These schemes provide more guidance but the simple one below is + sufficient. + *) +type 'x x_sig = 'x +constraint 'x = < annot: 'type_annotation; + type_expr_typecheck: 'bool1 > + +type 'x ast = { types : 'x type_decl reg list; constants : 'x const_decl reg list; parameter : 'x parameter_decl reg; @@ -154,6 +190,7 @@ and 'x ast = { block : 'x block reg; eof : eof } +constraint 'x = 'x x_sig and 'x parameter_decl = { kwd_parameter : kwd_parameter; @@ -162,18 +199,21 @@ and 'x parameter_decl = { param_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x storage_decl = { kwd_storage : kwd_storage; store_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x operations_decl = { kwd_operations : kwd_operations; op_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig (* Type declarations *) @@ -184,32 +224,79 @@ and 'x type_decl = { type_expr : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x type_expr = - Prod of 'x cartesian -| Sum of ('x variant, vbar) nsepseq reg -| Record of 'x record_type -| TypeApp of ('x type_name * 'x type_tuple) reg -| ParType of 'x type_expr par -| TAlias of 'x variable + Prod of ('x cartesian, ttrue) gadt_if +| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if +| Record of ('x record_type, ttrue) gadt_if +| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if +| ParType of ('x type_expr par, ttrue) gadt_if +| TAlias of ('x variable, ttrue) gadt_if + +| Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if +| Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if +| Unit of (unit, 'type_expr_typecheck) gadt_if +constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; + .. > +constraint 'x = 'x x_sig + +(* +and 'x type_expr = ('x cartesian, + ('x variant, vbar) nsepseq reg, + 'x record_type, + ('x type_name * 'x type_tuple) reg, + 'x type_expr par, + 'x variable, + + ('x type_expr list) * 'x type_expr, + 'x type_expr, + unit, + + 'type_expr_parse, + 'type_expr_typecheck) type_expr_gadt +constraint 'x = < type_expr_parse: 'type_expr_parse; + type_expr_typecheck: 'type_expr_typecheck; + .. > +constraint 'x = 'x x_sig + +and ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'type_expr_parse, 'type_expr_typecheck) type_expr_gadt = + Prod : 'a -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt +| Sum : 'b -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt +| Record : 'c -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt +| TypeApp : 'd -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt +| ParType : 'e -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt +| TAlias : 'f -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt + +| Function : 'g -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt +| Mutable : 'h -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt +| Unit : 'i -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt + *) and 'x cartesian = ('x type_expr, times) nsepseq reg +constraint 'x = 'x x_sig and 'x variant = ('x constr * kwd_of * 'x cartesian) reg +constraint 'x = 'x x_sig and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg +constraint 'x = 'x x_sig and 'x field_decls = ('x field_decl, semi) nsepseq +constraint 'x = 'x x_sig and 'x field_decl = ('x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x type_tuple = ('x type_name, comma) nsepseq par +constraint 'x = 'x x_sig (* Function and procedure declarations *) and 'x lambda_decl = FunDecl of 'x fun_decl reg | ProcDecl of 'x proc_decl reg +constraint 'x = 'x x_sig and 'x fun_decl = { kwd_function : kwd_function; @@ -224,6 +311,7 @@ and 'x fun_decl = { return : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x proc_decl = { kwd_procedure : kwd_procedure; @@ -234,16 +322,21 @@ and 'x proc_decl = { block : 'x block reg; terminator : semi option } +constraint 'x = 'x x_sig and 'x parameters = ('x param_decl, semi) nsepseq par +constraint 'x = 'x x_sig and 'x param_decl = ParamConst of 'x param_const | ParamVar of 'x param_var +constraint 'x = 'x x_sig and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x block = { opening : kwd_begin; @@ -251,11 +344,13 @@ and 'x block = { terminator : semi option; close : kwd_end } +constraint 'x = 'x x_sig and 'x local_decl = LocalLam of 'x lambda_decl | LocalConst of 'x const_decl reg | LocalVar of 'x var_decl reg +constraint 'x = 'x x_sig and 'x const_decl = { kwd_const : kwd_const; @@ -266,6 +361,7 @@ and 'x const_decl = { init : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x var_decl = { kwd_var : kwd_var; @@ -276,12 +372,15 @@ and 'x var_decl = { init : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x instructions = ('x instruction, semi) nsepseq reg +constraint 'x = 'x x_sig and 'x instruction = Single of 'x single_instr | Block of 'x block reg +constraint 'x = 'x x_sig and 'x single_instr = Cond of 'x conditional reg @@ -291,6 +390,7 @@ and 'x single_instr = | ProcCall of 'x fun_call | Null of kwd_null | Fail of (kwd_fail * 'x expr) reg +constraint 'x = 'x x_sig and 'x conditional = { kwd_if : kwd_if; @@ -300,6 +400,7 @@ and 'x conditional = { kwd_else : kwd_else; ifnot : 'x instruction } +constraint 'x = 'x x_sig and 'x match_instr = { kwd_match : kwd_match; @@ -309,22 +410,29 @@ and 'x match_instr = { cases : 'x cases; kwd_end : kwd_end } +constraint 'x = 'x x_sig and 'x cases = ('x case, vbar) nsepseq reg +constraint 'x = 'x x_sig and 'x case = ('x pattern * arrow * 'x instruction) reg +constraint 'x = 'x x_sig and 'x ass_instr = ('x variable * ass * 'x expr) reg +constraint 'x = 'x x_sig and 'x loop = While of 'x while_loop | For of 'x for_loop +constraint 'x = 'x x_sig and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg +constraint 'x = 'x x_sig and 'x for_loop = ForInt of 'x for_int reg | ForCollect of 'x for_collect reg +constraint 'x = 'x x_sig and 'x for_int = { kwd_for : kwd_for; @@ -335,6 +443,7 @@ and 'x for_int = { step : (kwd_step * 'x expr) option; block : 'x block reg } +constraint 'x = 'x x_sig and 'x for_collect = { kwd_for : kwd_for; @@ -344,6 +453,7 @@ and 'x for_collect = { expr : 'x expr; block : 'x block reg } +constraint 'x = 'x x_sig (* Expressions *) @@ -383,33 +493,43 @@ and 'x expr = | SomeApp of (c_Some * 'x arguments) reg | MapLookUp of 'x map_lookup reg | ParExpr of 'x expr par +constraint 'x = 'x x_sig and 'x tuple = ('x expr, comma) nsepseq par +constraint 'x = 'x x_sig and 'x empty_list = (lbracket * rbracket * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x empty_set = (lbrace * rbrace * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x none_expr = (c_None * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x fun_call = ('x fun_name * 'x arguments) reg +constraint 'x = 'x x_sig and 'x arguments = 'x tuple +constraint 'x = 'x x_sig and 'x constr_app = ('x constr * 'x arguments) reg +constraint 'x = 'x x_sig and 'x map_lookup = { map_name : 'x variable; selector : dot; index : 'x expr brackets } +constraint 'x = 'x x_sig (* Patterns *) and 'x pattern = ('x core_pattern, cons) nsepseq reg +constraint 'x = 'x x_sig and 'x core_pattern = PVar of Lexer.lexeme reg @@ -424,22 +544,39 @@ and 'x core_pattern = | PSome of (c_Some * 'x core_pattern par) reg | PList of 'x list_pattern | PTuple of ('x core_pattern, comma) nsepseq par +constraint 'x = 'x x_sig and 'x list_pattern = Sugar of ('x core_pattern, comma) sepseq brackets | Raw of ('x core_pattern * cons * 'x pattern) par +constraint 'x = 'x x_sig + +(* Variations on the AST *) + +type parse_phase = < + annot: unit; + type_expr_typecheck: tfalse; +> + +type typecheck_phase = < + annot: typecheck_phase type_expr; + type_expr_typecheck: ttrue; +> + +type t = parse_phase ast (* Projecting regions *) open! Region -let type_expr_to_region = function - Prod node -> node.region -| Sum node -> node.region -| Record node -> node.region -| TypeApp node -> node.region -| ParType node -> node.region -| TAlias node -> node.region +let type_expr_to_region : parse_phase type_expr -> region = function + Prod (Present node) -> node.region +| Sum (Present node) -> node.region +| Record (Present node) -> node.region +| TypeApp (Present node) -> node.region +| ParType (Present node) -> node.region +| TAlias (Present node) -> node.region +| _ -> . let expr_to_region = function Or {region; _} diff --git a/AST.mli b/AST.mli index cb6fbcd2b..d89d92b25 100644 --- a/AST.mli +++ b/AST.mli @@ -126,9 +126,45 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -type t = < ty:unit > ast +type ttrue = TTrue +type tfalse = TFalse +type ('a, 'type_expr_typecheck) gadt_if = + Present : 'a -> ('a, ttrue) gadt_if -and 'x ast = { +(* It is possible to further ensure well-typedness at the meta level + by using the following constraint: + + type ttrue = [`True] + type tfalse = [`False] + + type 'x x_sig = 'x + constraint 'x = < annot: 'ty; + type_expr_typecheck: [< `True | `False] > + + we could also use a single selector for type_expr, as long as + the fields are monotonic: + + type z = [`Z] + type 'i s = [`S of 'i] + type 'is type_level_int = [< `S of 'i | `Z] + constraint 'i = 'prev type_level_int + + type parse_phase = z + type typecheck_phase = z s + type further_phase = z s s + + type 'x x_sig = 'x + constraint 'x = < annot: 'ty; + type_expr: 'type_expr > + + These schemes provide more guidance but the simple one below is + sufficient. + *) +type 'x x_sig = 'x +constraint 'x = < annot: 'type_annotation; + type_expr_typecheck: 'bool1 > + +type 'x ast = { types : 'x type_decl reg list; constants : 'x const_decl reg list; parameter : 'x parameter_decl reg; @@ -138,6 +174,7 @@ and 'x ast = { block : 'x block reg; eof : eof } +constraint 'x = 'x x_sig and 'x parameter_decl = { kwd_parameter : kwd_parameter; @@ -146,18 +183,21 @@ and 'x parameter_decl = { param_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x storage_decl = { kwd_storage : kwd_storage; store_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x operations_decl = { kwd_operations : kwd_operations; op_type : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig (* Type declarations *) @@ -168,32 +208,47 @@ and 'x type_decl = { type_expr : 'x type_expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x type_expr = - Prod of 'x cartesian -| Sum of ('x variant, vbar) nsepseq reg -| Record of 'x record_type -| TypeApp of ('x type_name * 'x type_tuple) reg -| ParType of 'x type_expr par -| TAlias of 'x variable + Prod of ('x cartesian, ttrue) gadt_if +| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if +| Record of ('x record_type, ttrue) gadt_if +| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if +| ParType of ('x type_expr par, ttrue) gadt_if +| TAlias of ('x variable, ttrue) gadt_if + +| Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if +| Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if +| Unit of (unit, 'type_expr_typecheck) gadt_if +constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; + .. > +constraint 'x = 'x x_sig and 'x cartesian = ('x type_expr, times) nsepseq reg +constraint 'x = 'x x_sig and 'x variant = ('x constr * kwd_of * 'x cartesian) reg +constraint 'x = 'x x_sig and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg +constraint 'x = 'x x_sig and 'x field_decls = ('x field_decl, semi) nsepseq +constraint 'x = 'x x_sig and 'x field_decl = ('x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x type_tuple = ('x type_name, comma) nsepseq par +constraint 'x = 'x x_sig (* Function and procedure declarations *) and 'x lambda_decl = FunDecl of 'x fun_decl reg | ProcDecl of 'x proc_decl reg +constraint 'x = 'x x_sig and 'x fun_decl = { kwd_function : kwd_function; @@ -208,6 +263,7 @@ and 'x fun_decl = { return : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x proc_decl = { kwd_procedure : kwd_procedure; @@ -218,16 +274,21 @@ and 'x proc_decl = { block : 'x block reg; terminator : semi option } +constraint 'x = 'x x_sig and 'x parameters = ('x param_decl, semi) nsepseq par +constraint 'x = 'x x_sig and 'x param_decl = ParamConst of 'x param_const | ParamVar of 'x param_var +constraint 'x = 'x x_sig and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg +constraint 'x = 'x x_sig and 'x block = { opening : kwd_begin; @@ -235,11 +296,13 @@ and 'x block = { terminator : semi option; close : kwd_end } +constraint 'x = 'x x_sig and 'x local_decl = LocalLam of 'x lambda_decl | LocalConst of 'x const_decl reg | LocalVar of 'x var_decl reg +constraint 'x = 'x x_sig and 'x const_decl = { kwd_const : kwd_const; @@ -250,6 +313,7 @@ and 'x const_decl = { init : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x var_decl = { kwd_var : kwd_var; @@ -260,12 +324,15 @@ and 'x var_decl = { init : 'x expr; terminator : semi option } +constraint 'x = 'x x_sig and 'x instructions = ('x instruction, semi) nsepseq reg +constraint 'x = 'x x_sig and 'x instruction = Single of 'x single_instr | Block of 'x block reg +constraint 'x = 'x x_sig and 'x single_instr = Cond of 'x conditional reg @@ -275,6 +342,7 @@ and 'x single_instr = | ProcCall of 'x fun_call | Null of kwd_null | Fail of (kwd_fail * 'x expr) reg +constraint 'x = 'x x_sig and 'x conditional = { kwd_if : kwd_if; @@ -284,6 +352,7 @@ and 'x conditional = { kwd_else : kwd_else; ifnot : 'x instruction } +constraint 'x = 'x x_sig and 'x match_instr = { kwd_match : kwd_match; @@ -293,22 +362,29 @@ and 'x match_instr = { cases : 'x cases; kwd_end : kwd_end } +constraint 'x = 'x x_sig and 'x cases = ('x case, vbar) nsepseq reg +constraint 'x = 'x x_sig and 'x case = ('x pattern * arrow * 'x instruction) reg +constraint 'x = 'x x_sig and 'x ass_instr = ('x variable * ass * 'x expr) reg +constraint 'x = 'x x_sig and 'x loop = While of 'x while_loop | For of 'x for_loop +constraint 'x = 'x x_sig and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg +constraint 'x = 'x x_sig and 'x for_loop = ForInt of 'x for_int reg | ForCollect of 'x for_collect reg +constraint 'x = 'x x_sig and 'x for_int = { kwd_for : kwd_for; @@ -319,6 +395,7 @@ and 'x for_int = { step : (kwd_step * 'x expr) option; block : 'x block reg } +constraint 'x = 'x x_sig and 'x for_collect = { kwd_for : kwd_for; @@ -328,6 +405,7 @@ and 'x for_collect = { expr : 'x expr; block : 'x block reg } +constraint 'x = 'x x_sig (* Expressions *) @@ -367,33 +445,43 @@ and 'x expr = | SomeApp of (c_Some * 'x arguments) reg | MapLookUp of 'x map_lookup reg | ParExpr of 'x expr par +constraint 'x = 'x x_sig and 'x tuple = ('x expr, comma) nsepseq par +constraint 'x = 'x x_sig and 'x empty_list = (lbracket * rbracket * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x empty_set = (lbrace * rbrace * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x none_expr = (c_None * colon * 'x type_expr) par +constraint 'x = 'x x_sig and 'x fun_call = ('x fun_name * 'x arguments) reg +constraint 'x = 'x x_sig and 'x arguments = 'x tuple +constraint 'x = 'x x_sig and 'x constr_app = ('x constr * 'x arguments) reg +constraint 'x = 'x x_sig and 'x map_lookup = { map_name : 'x variable; selector : dot; index : 'x expr brackets } +constraint 'x = 'x x_sig (* Patterns *) and 'x pattern = ('x core_pattern, cons) nsepseq reg +constraint 'x = 'x x_sig and 'x core_pattern = PVar of Lexer.lexeme reg @@ -408,14 +496,30 @@ and 'x core_pattern = | PSome of (c_Some * 'x core_pattern par) reg | PList of 'x list_pattern | PTuple of ('x core_pattern, comma) nsepseq par +constraint 'x = 'x x_sig and 'x list_pattern = Sugar of ('x core_pattern, comma) sepseq brackets | Raw of ('x core_pattern * cons * 'x pattern) par +constraint 'x = 'x x_sig + +(* Variations on the AST *) + +type parse_phase = < + annot: unit; + type_expr_typecheck: tfalse; +> + +type typecheck_phase = < + annot: typecheck_phase type_expr; + type_expr_typecheck: ttrue; +> + +type t = parse_phase ast (* Projecting regions *) -val type_expr_to_region : 'x type_expr -> Region.t +val type_expr_to_region : parse_phase type_expr -> Region.t val expr_to_region : 'x expr -> Region.t diff --git a/Parser.mly b/Parser.mly index d3aca6dcc..547e20e68 100644 --- a/Parser.mly +++ b/Parser.mly @@ -171,9 +171,9 @@ type_decl: in {region; value}} type_expr: - cartesian { Prod $1 } -| sum_type { Sum $1 } -| record_type { Record $1 } + cartesian { Prod (Present $1) } +| sum_type { Sum (Present $1) } +| record_type { Record (Present $1) } cartesian: nsepseq(core_type,TIMES) { @@ -183,14 +183,14 @@ cartesian: core_type: type_name { - TAlias $1 + TAlias (Present $1) } | type_name type_tuple { let region = cover $1.region $2.region - in TypeApp {region; value = $1,$2} + in TypeApp (Present {region; value = $1,$2}) } | par(type_expr) { - ParType $1 + ParType (Present $1) } type_tuple: diff --git a/ParserMain.ml b/ParserMain.ml index 0c940bfb6..c23833c25 100644 --- a/ParserMain.ml +++ b/ParserMain.ml @@ -57,8 +57,10 @@ let tokeniser = read ~log let () = try let ast = Parser.program tokeniser buffer in - if Utils.String.Set.mem "parser" EvalOpt.verbose - then Print.print_tokens ast + let () = if Utils.String.Set.mem "parser" EvalOpt.verbose + then Print.print_tokens ast in + let _ = Typecheck2.tc_ast ast + in () with Lexer.Error err -> close_all (); diff --git a/Print.ml b/Print.ml index c41da7f0a..389a1f54d 100644 --- a/Print.ml +++ b/Print.ml @@ -47,7 +47,7 @@ and print_int _visitor {region; value = lexeme, abstract} = (* Main printing function *) -and print_tokens (v: 'x visitor) ast = +and print_tokens : 'x visitor -> 'x ast -> unit = fun v ast -> List.iter v.type_decl ast.types; v.parameter_decl ast.parameter; v.storage_decl ast.storage; @@ -56,87 +56,90 @@ and print_tokens (v: 'x visitor) ast = v.block ast.block; v.token ast.eof "EOF" -and print_parameter_decl (v: 'x visitor) {value=node; _} = +and print_parameter_decl (v : 'xvisitor) {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: 'x visitor) {value=node; _} = +and print_storage_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_storage "storage"; v.type_expr node.store_type; v.terminator node.terminator -and print_operations_decl (v: 'x visitor) {value=node; _} = +and print_operations_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_operations "operations"; v.type_expr node.op_type; v.terminator node.terminator -and print_type_decl (v: 'x visitor) {value=node; _} = +and print_type_decl (v : 'xvisitor) {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: 'x 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_type_expr (v : 'xvisitor) = function + Prod (Present cartesian) -> v.cartesian cartesian +| Sum (Present sum_type) -> v.sum_type sum_type +| Record (Present record_type) -> v.record_type record_type +| TypeApp (Present type_app) -> v.type_app type_app +| ParType (Present par_type) -> v.par_type par_type +| TAlias (Present type_alias) -> v.var type_alias +| Function _function' -> printf "TODO" +| Mutable _mutable' -> printf "TODO" +| Unit _unit' -> printf "TODO" -and print_cartesian (v: 'x visitor) {value=sequence; _} = +and print_cartesian (v : 'xvisitor) {value=sequence; _} = v.nsepseq "*" v.type_expr sequence -and print_variant (v: 'x visitor) {value=node; _} = +and print_variant (v : 'xvisitor) {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: 'x visitor) {value=sequence; _} = +and print_sum_type (v : 'xvisitor) {value=sequence; _} = v.nsepseq "|" v.variant sequence -and print_record_type (v: 'x visitor) {value=node; _} = +and print_record_type (v : 'xvisitor) {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: 'x visitor) {value=node; _} = +and print_type_app (v : 'xvisitor) {value=node; _} = let type_name, type_tuple = node in v.var type_name; v.type_tuple type_tuple -and print_par_type (v: 'x visitor) {value=node; _} = +and print_par_type (v : 'xvisitor) {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: 'x visitor) sequence = +and print_field_decls (v : 'xvisitor) sequence = v.nsepseq ";" v.field_decl sequence -and print_field_decl (v: 'x visitor) {value=node; _} = +and print_field_decl (v : 'xvisitor) {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: 'x visitor) {value=node; _} = +and print_type_tuple (v : 'xvisitor) {value=node; _} = let lpar, sequence, rpar = node in v.token lpar "("; v.nsepseq "," v.var sequence; v.token rpar ")" -and print_lambda_decl (v: 'x visitor) = function +and print_lambda_decl (v : 'xvisitor) = function FunDecl fun_decl -> v.fun_decl fun_decl | ProcDecl proc_decl -> v.proc_decl proc_decl -and print_fun_decl (v: 'x visitor) {value=node; _} = +and print_fun_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_function "function"; v.var node.name; v.parameters node.param; @@ -149,7 +152,7 @@ and print_fun_decl (v: 'x visitor) {value=node; _} = v.expr node.return; v.terminator node.terminator -and print_proc_decl (v: 'x visitor) {value=node; _} = +and print_proc_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_procedure "procedure"; v.var node.name; v.parameters node.param; @@ -158,45 +161,45 @@ and print_proc_decl (v: 'x visitor) {value=node; _} = v.block node.block; v.terminator node.terminator -and print_parameters (v: 'x visitor) {value=node; _} = +and print_parameters (v : 'xvisitor) {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: 'x visitor) = function +and print_param_decl (v : 'xvisitor) = function ParamConst param_const -> v.param_const param_const | ParamVar param_var -> v.param_var param_var -and print_param_const (v: 'x visitor) {value=node; _} = +and print_param_const (v : 'xvisitor) {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: 'x visitor) {value=node; _} = +and print_param_var (v : 'xvisitor) {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: 'x visitor) {value=node; _} = +and print_block (v : 'xvisitor) {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: 'x visitor) sequence = +and print_local_decls (v : 'xvisitor) sequence = List.iter v.local_decl sequence -and print_local_decl (v: 'x visitor) = function +and print_local_decl (v : 'xvisitor) = function LocalLam decl -> v.lambda_decl decl | LocalConst decl -> v.const_decl decl | LocalVar decl -> v.var_decl decl -and print_const_decl (v: 'x visitor) {value=node; _} = +and print_const_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_const "const"; v.var node.name; v.token node.colon ":"; @@ -205,7 +208,7 @@ and print_const_decl (v: 'x visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_var_decl (v: 'x visitor) {value=node; _} = +and print_var_decl (v : 'xvisitor) {value=node; _} = v.token node.kwd_var "var"; v.var node.name; v.token node.colon ":"; @@ -214,14 +217,14 @@ and print_var_decl (v: 'x visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_instructions (v: 'x visitor) {value=sequence; _} = +and print_instructions (v : 'xvisitor) {value=sequence; _} = v.nsepseq ";" v.instruction sequence -and print_instruction (v: 'x visitor) = function +and print_instruction (v : 'xvisitor) = function Single instr -> v.single_instr instr | Block block -> v.block block -and print_single_instr (v: 'x visitor) = function +and print_single_instr (v : 'xvisitor) = function Cond {value; _} -> v.conditional value | Match {value; _} -> v.match_instr value | Ass instr -> v.ass_instr instr @@ -230,11 +233,11 @@ and print_single_instr (v: 'x visitor) = function | Null kwd_null -> v.token kwd_null "null" | Fail {value; _} -> v.fail value -and print_fail (v: 'x visitor) (kwd_fail, expr) = +and print_fail (v : 'xvisitor) (kwd_fail, expr) = v.token kwd_fail "fail"; v.expr expr -and print_conditional (v: 'x visitor) node = +and print_conditional (v : 'xvisitor) node = v.token node.kwd_if "if"; v.expr node.test; v.token node.kwd_then "then"; @@ -242,43 +245,43 @@ and print_conditional (v: 'x visitor) node = v.token node.kwd_else "else"; v.instruction node.ifnot -and print_match_instr (v: 'x visitor) node = +and print_match_instr (v : 'xvisitor) 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: 'x visitor) {value=sequence; _} = +and print_cases (v : 'xvisitor) {value=sequence; _} = v.nsepseq "|" v.case sequence -and print_case (v: 'x visitor) {value=node; _} = +and print_case (v : 'xvisitor) {value=node; _} = let pattern, arrow, instruction = node in v.pattern pattern; v.token arrow "->"; v.instruction instruction -and print_ass_instr (v: 'x visitor) {value=node; _} = +and print_ass_instr (v : 'xvisitor) {value=node; _} = let variable, ass, expr = node in v.var variable; v.token ass ":="; v.expr expr -and print_loop (v: 'x visitor) = function +and print_loop (v : 'xvisitor) = function While while_loop -> v.while_loop while_loop | For for_loop -> v.for_loop for_loop -and print_while_loop (v: 'x visitor) {value=node; _} = +and print_while_loop (v : 'xvisitor) {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: 'x visitor) = function +and print_for_loop (v : 'xvisitor) = function ForInt for_int -> v.for_int for_int | ForCollect for_collect -> v.for_collect for_collect -and print_for_int (v: 'x visitor) ({value=node; _} : 'x for_int reg) = +and print_for_int (v : 'xvisitor) ({value=node; _} : 'x for_int reg) = v.token node.kwd_for "for"; v.ass_instr node.ass; v.down node.down; @@ -287,17 +290,17 @@ and print_for_int (v: 'x visitor) ({value=node; _} : 'x for_int reg) = v.step node.step; v.block node.block -and print_down (v: 'x visitor) = function +and print_down (v : 'xvisitor) = function Some kwd_down -> v.token kwd_down "down" | None -> () -and print_step (v: 'x visitor) = function +and print_step (v : 'xvisitor) = function Some (kwd_step, expr) -> v.token kwd_step "step"; v.expr expr | None -> () -and print_for_collect (v: 'x visitor) ({value=node; _} : 'x for_collect reg) = +and print_for_collect (v : 'xvisitor) ({value=node; _} : 'x for_collect reg) = v.token node.kwd_for "for"; v.var node.var; v.bind_to node.bind_to; @@ -305,13 +308,13 @@ and print_for_collect (v: 'x visitor) ({value=node; _} : 'x for_collect reg) = v.expr node.expr; v.block node.block -and print_bind_to (v: 'x visitor) = function +and print_bind_to (v : 'xvisitor) = function Some (arrow, variable) -> v.token arrow "->"; v.var variable | None -> () -and print_expr (v: 'x visitor) = function +and print_expr (v : 'xvisitor) = function Or {value = expr1, bool_or, expr2; _} -> v.expr expr1; v.token bool_or "||"; v.expr expr2 | And {value = expr1, bool_and, expr2; _} -> @@ -365,19 +368,19 @@ and print_expr (v: 'x visitor) = function | MapLookUp lookup -> v.map_lookup lookup | ParExpr pexpr -> v.par_expr pexpr -and print_tuple (v: 'x visitor) {value=node; _} = +and print_tuple (v : 'xvisitor) {value=node; _} = let lpar, sequence, rpar = node in v.token lpar "("; v.nsepseq "," v.expr sequence; v.token rpar ")" -and print_list (v: 'x visitor) {value=node; _} = +and print_list (v : 'xvisitor) {value=node; _} = let lbra, sequence, rbra = node in v.token lbra "["; v.nsepseq "," v.expr sequence; v.token rbra "]" -and print_empty_list (v: 'x visitor) {value=node; _} = +and print_empty_list (v : 'xvisitor) {value=node; _} = let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in v.token lpar "("; v.token lbracket "["; @@ -386,13 +389,13 @@ and print_empty_list (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_set (v: 'x visitor) {value=node; _} = +and print_set (v : 'xvisitor) {value=node; _} = let lbrace, sequence, rbrace = node in v.token lbrace "{"; v.nsepseq "," v.expr sequence; v.token rbrace "}" -and print_empty_set (v: 'x visitor) {value=node; _} = +and print_empty_set (v : 'xvisitor) {value=node; _} = let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in v.token lpar "("; v.token lbrace "{"; @@ -401,7 +404,7 @@ and print_empty_set (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_none_expr (v: 'x visitor) {value=node; _} = +and print_none_expr (v : 'xvisitor) {value=node; _} = let lpar, (c_None, colon, type_expr), rpar = node in v.token lpar "("; v.token c_None "None"; @@ -409,22 +412,22 @@ and print_none_expr (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_fun_call (v: 'x visitor) {value=node; _} = +and print_fun_call (v : 'xvisitor) {value=node; _} = let fun_name, arguments = node in v.var fun_name; v.tuple arguments -and print_constr_app (v: 'x visitor) {value=node; _} = +and print_constr_app (v : 'xvisitor) {value=node; _} = let constr, arguments = node in v.constr constr; v.tuple arguments -and print_some_app (v: 'x visitor) {value=node; _} = +and print_some_app (v : 'xvisitor) {value=node; _} = let c_Some, arguments = node in v.token c_Some "Some"; v.tuple arguments -and print_map_lookup (v: 'x visitor) {value=node; _} = +and print_map_lookup (v : 'xvisitor) {value=node; _} = let {value = lbracket, expr, rbracket; _} = node.index in v.var node.map_name; v.token node.selector "."; @@ -432,16 +435,16 @@ and print_map_lookup (v: 'x visitor) {value=node; _} = v.expr expr; v.token rbracket "]" -and print_par_expr (v: 'x visitor) {value=node; _} = +and print_par_expr (v : 'xvisitor) {value=node; _} = let lpar, expr, rpar = node in v.token lpar "("; v.expr expr; v.token rpar ")" -and print_pattern (v: 'x visitor) {value=sequence; _} = +and print_pattern (v : 'xvisitor) {value=sequence; _} = v.nsepseq "<:" v.core_pattern sequence -and print_core_pattern (v: 'x visitor) = function +and print_core_pattern (v : 'xvisitor) = function PVar var -> v.var var | PWild wild -> v.token wild "_" | PInt i -> v.int i @@ -455,28 +458,28 @@ and print_core_pattern (v: 'x visitor) = function | PList pattern -> v.list_pattern pattern | PTuple ptuple -> v.ptuple ptuple -and print_psome (v: 'x visitor) {value=node; _} = +and print_psome (v : 'xvisitor) {value=node; _} = let c_Some, patterns = node in v.token c_Some "Some"; v.patterns patterns -and print_patterns (v: 'x visitor) {value=node; _} = +and print_patterns (v : 'xvisitor) {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: 'x visitor) = function +and print_list_pattern (v : 'xvisitor) = function Sugar sugar -> v.sugar sugar | Raw raw -> v.raw raw -and print_sugar (v: 'x visitor) {value=node; _} = +and print_sugar (v : 'xvisitor) {value=node; _} = let lbracket, sequence, rbracket = node in v.token lbracket "["; v.sepseq "," v.core_pattern sequence; v.token rbracket "]" -and print_raw (v: 'x visitor) {value=node; _} = +and print_raw (v : 'xvisitor) {value=node; _} = let lpar, (core_pattern, cons, pattern), rpar = node in v.token lpar "("; v.core_pattern core_pattern; @@ -484,13 +487,13 @@ and print_raw (v: 'x visitor) {value=node; _} = v.pattern pattern; v.token rpar ")" -and print_ptuple (v: 'x visitor) {value=node; _} = +and print_ptuple (v : 'xvisitor) {value=node; _} = let lpar, sequence, rpar = node in v.token lpar "("; v.nsepseq "," v.core_pattern sequence; v.token rpar ")" -and print_terminator (v: 'x visitor) = function +and print_terminator (v : 'xvisitor) = function Some semi -> v.token semi ";" | None -> () diff --git a/Print.mli b/Print.mli index 66fae6dfa..97621a8fc 100644 --- a/Print.mli +++ b/Print.mli @@ -2,4 +2,4 @@ open AST -val print_tokens : t -> unit +val print_tokens : parse_phase ast -> unit diff --git a/Typecheck2.ml b/Typecheck2.ml new file mode 100644 index 000000000..ae5d9bdb3 --- /dev/null +++ b/Typecheck2.ml @@ -0,0 +1,337 @@ +module SMap = Map.Make(String) + +open AST + +type i = parse_phase +type typecheck_phase = < + annot: typecheck_phase type_expr; + type_expr_typecheck: tfalse; +> +type o = typecheck_phase + +type te = o type_expr list SMap.t (* Type environment *) +type ve = o type_expr list SMap.t (* Value environment *) +type tve = te * ve + +let id (ast : i ast) : o ast = {ast with eof = ast.eof} + +(* Utilities *) + +let fold_map f a l = + let f (acc, l) elem = + let acc', elem' = f acc elem + in acc', (elem' :: l) in + let last_acc, last_l = List.fold_left f (a, []) l + in last_acc, List.rev last_l + +let reg ({value;region} : 'a reg) (f : 'a -> 'b) : 'b reg = {value = f value; region} +let unreg ({value;_} : 'a reg) : 'a = value + +(* Typecheck *) + +let tc_type_decl (te, ve : tve) (td : i type_decl reg) : tve * o type_decl reg = + (te, ve), (unreg td) + +let tc_types (tve : tve) (types : i type_decl reg list) = + fold_map tc_type_decl tve types + +let tc_ast (tve : tve) (ast : i ast) = + let {types;constants;parameter;storage;operations;lambdas;block;eof} = ast in + let tve, types = tc_types tve types in + let ast = {types;constants;parameter;storage;operations;lambdas;block;eof} in + tve, ast + +let tc_ast ast = + let tve, ast = tc_ast (SMap.empty, SMap.empty) ast in + let _ = tve in (* Drop the final type and value environment *) + ast + +(* +open Region +open Utils +type new_t = < ty: int > 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 'a parameter_decl = { + kwd_parameter : kwd_parameter; + name : 'a variable; + colon : colon; + param_type : 'a type_expr; + terminator : semi option +} + +and 'a storage_decl = { + kwd_storage : kwd_storage; + store_type : 'a type_expr; + terminator : semi option +} + +and 'a operations_decl = { + kwd_operations : kwd_operations; + op_type : 'a 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 '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 'a cartesian = ('a type_expr, times) nsepseq reg + +and 'a variant = ('a constr * kwd_of * 'a cartesian) reg + +and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg + +and 'a field_decls = ('a field_decl, semi) nsepseq + +and 'a field_decl = ('a variable * colon * 'a type_expr) reg + +and 'a type_tuple = ('a 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 '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 '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 'a parameters = ('a param_decl, semi) nsepseq par + +and 'a param_decl = + ParamConst of 'a param_const +| ParamVar of 'a param_var + +and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg + +and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg + +and 'a block = { + opening : kwd_begin; + instr : 'a 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 '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 '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 'a instructions = ('a instruction, semi) nsepseq reg + +and 'a instruction = + Single of 'a single_instr +| Block of 'a 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 +| Null of kwd_null +| Fail of (kwd_fail * 'a 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 '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 'a cases = ('a case, vbar) nsepseq reg + +and 'a case = ('a pattern * arrow * 'a instruction) reg + +and 'a ass_instr = ('a variable * ass * 'a expr) reg + +and 'a loop = + While of 'a while_loop +| For of 'a for_loop + +and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg + +and 'a for_loop = + ForInt of 'a for_int reg +| ForCollect of 'a 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 '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 '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 +| Bytes of (Lexer.lexeme * MBytes.t) reg +| 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 + +and 'a tuple = ('a expr, comma) nsepseq par + +and 'a empty_list = + (lbracket * rbracket * colon * 'a type_expr) par + +and 'a empty_set = + (lbrace * rbrace * colon * 'a type_expr) par + +and 'a none_expr = + (c_None * colon * 'a type_expr) par + +and 'a fun_call = ('a fun_name * 'a arguments) reg + +and 'a arguments = 'a tuple + +and 'a constr_app = ('a constr * 'a arguments) reg + +and 'a map_lookup = { + map_name : 'a variable; + selector : dot; + index : 'a expr brackets +} + +(* Patterns *) + +and 'a pattern = ('a core_pattern, cons) nsepseq reg + +and 'a core_pattern = + PVar of Lexer.lexeme reg +| PWild of wild +| PInt of (Lexer.lexeme * Z.t) reg +| PBytes of (Lexer.lexeme * MBytes.t) reg +| PString of Lexer.lexeme reg +| PUnit of c_Unit +| PFalse of c_False +| PTrue of c_True +| PNone of c_None +| PSome of (c_Some * 'a core_pattern par) reg +| PList of 'a list_pattern +| PTuple of ('a 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 + *) diff --git a/Typecheck2.mli b/Typecheck2.mli new file mode 100644 index 000000000..8f5bf59e1 --- /dev/null +++ b/Typecheck2.mli @@ -0,0 +1 @@ +val tc_ast : AST.parse_phase AST.ast -> AST.typecheck_phase AST.ast diff --git a/typecheck.ml b/typecheck.ml index b768a9949..dc2bc374a 100644 --- a/typecheck.ml +++ b/typecheck.ml @@ -1,8 +1,3 @@ - - - - - (* module I = AST (* In *) From cbf565d4c07407d156e0e7f5cf77dc5240a836eb Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 20:41:58 +0100 Subject: [PATCH 4/8] Does not work --- AST.mli | 16 ++++------------ Typecheck2.ml | 5 +---- 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/AST.mli b/AST.mli index d89d92b25..2f9610e89 100644 --- a/AST.mli +++ b/AST.mli @@ -161,8 +161,7 @@ type ('a, 'type_expr_typecheck) gadt_if = sufficient. *) type 'x x_sig = 'x -constraint 'x = < annot: 'type_annotation; - type_expr_typecheck: 'bool1 > +constraint 'x = 'type_annotation * 'type_expr_typecheck type 'x ast = { types : 'x type_decl reg list; @@ -221,8 +220,7 @@ and 'x type_expr = | Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if | Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if | Unit of (unit, 'type_expr_typecheck) gadt_if -constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; - .. > +constraint 'x = ('type_annotation * 'type_expr_typecheck) constraint 'x = 'x x_sig and 'x cartesian = ('x type_expr, times) nsepseq reg @@ -505,15 +503,9 @@ constraint 'x = 'x x_sig (* Variations on the AST *) -type parse_phase = < - annot: unit; - type_expr_typecheck: tfalse; -> +type parse_phase = (unit * tfalse) -type typecheck_phase = < - annot: typecheck_phase type_expr; - type_expr_typecheck: ttrue; -> +type typecheck_phase = (parse_phase type_expr * ttrue) type t = parse_phase ast diff --git a/Typecheck2.ml b/Typecheck2.ml index ae5d9bdb3..058a25cbf 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -3,10 +3,7 @@ module SMap = Map.Make(String) open AST type i = parse_phase -type typecheck_phase = < - annot: typecheck_phase type_expr; - type_expr_typecheck: tfalse; -> +type typecheck_phase = (parse_phase type_expr * tfalse) type o = typecheck_phase type te = o type_expr list SMap.t (* Type environment *) From a6585b6e9197d109cd59665c52643cc4a64628eb Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 21:00:44 +0100 Subject: [PATCH 5/8] Revert "Does not work" This reverts commit cbf565d4c07407d156e0e7f5cf77dc5240a836eb. --- AST.mli | 16 ++++++++++++---- Typecheck2.ml | 5 ++++- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/AST.mli b/AST.mli index 2f9610e89..d89d92b25 100644 --- a/AST.mli +++ b/AST.mli @@ -161,7 +161,8 @@ type ('a, 'type_expr_typecheck) gadt_if = sufficient. *) type 'x x_sig = 'x -constraint 'x = 'type_annotation * 'type_expr_typecheck +constraint 'x = < annot: 'type_annotation; + type_expr_typecheck: 'bool1 > type 'x ast = { types : 'x type_decl reg list; @@ -220,7 +221,8 @@ and 'x type_expr = | Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if | Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if | Unit of (unit, 'type_expr_typecheck) gadt_if -constraint 'x = ('type_annotation * 'type_expr_typecheck) +constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; + .. > constraint 'x = 'x x_sig and 'x cartesian = ('x type_expr, times) nsepseq reg @@ -503,9 +505,15 @@ constraint 'x = 'x x_sig (* Variations on the AST *) -type parse_phase = (unit * tfalse) +type parse_phase = < + annot: unit; + type_expr_typecheck: tfalse; +> -type typecheck_phase = (parse_phase type_expr * ttrue) +type typecheck_phase = < + annot: typecheck_phase type_expr; + type_expr_typecheck: ttrue; +> type t = parse_phase ast diff --git a/Typecheck2.ml b/Typecheck2.ml index 058a25cbf..ae5d9bdb3 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -3,7 +3,10 @@ module SMap = Map.Make(String) open AST type i = parse_phase -type typecheck_phase = (parse_phase type_expr * tfalse) +type typecheck_phase = < + annot: typecheck_phase type_expr; + type_expr_typecheck: tfalse; +> type o = typecheck_phase type te = o type_expr list SMap.t (* Type environment *) From 78629b6652edd750d55aa192a8179762b3c34f3c Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 21:00:47 +0100 Subject: [PATCH 6/8] =?UTF-8?q?Revert=20"WIP=E2=80=A6"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This reverts commit 9b9760f052c85202cd59e7132d2649d41e54424f. --- AST.ml | 167 +++--------------------- AST.mli | 122 ++---------------- Parser.mly | 12 +- ParserMain.ml | 6 +- Print.ml | 145 +++++++++++---------- Print.mli | 2 +- Typecheck2.ml | 337 ------------------------------------------------- Typecheck2.mli | 1 - typecheck.ml | 5 + 9 files changed, 109 insertions(+), 688 deletions(-) delete mode 100644 Typecheck2.ml delete mode 100644 Typecheck2.mli diff --git a/AST.ml b/AST.ml index 6f62f6e98..940b562c4 100644 --- a/AST.ml +++ b/AST.ml @@ -142,45 +142,9 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -type ttrue = TTrue -type tfalse = TFalse -type ('a, 'type_expr_typecheck) gadt_if = - Present : 'a -> ('a, ttrue) gadt_if +type t = < ty: unit > ast -(* It is possible to further ensure well-typedness at the meta level - by using the following constraint: - - type ttrue = [`True] - type tfalse = [`False] - - type 'x x_sig = 'x - constraint 'x = < ty: 'ty; - type_expr_typecheck: [< `True | `False] > - - we could also use a single selector for type_expr, as long as - the fields are monotonic: - - type z = [`Z] - type 'i s = [`S of 'i] - type 'is type_level_int = [< `S of 'i | `Z] - constraint 'i = 'prev type_level_int - - type parse_phase = z - type typecheck_phase = z s - type further_phase = z s s - - type 'x x_sig = 'x - constraint 'x = < ty: 'ty; - type_expr: 'type_expr > - - These schemes provide more guidance but the simple one below is - sufficient. - *) -type 'x x_sig = 'x -constraint 'x = < annot: 'type_annotation; - type_expr_typecheck: 'bool1 > - -type 'x ast = { +and 'x ast = { types : 'x type_decl reg list; constants : 'x const_decl reg list; parameter : 'x parameter_decl reg; @@ -190,7 +154,6 @@ type 'x ast = { block : 'x block reg; eof : eof } -constraint 'x = 'x x_sig and 'x parameter_decl = { kwd_parameter : kwd_parameter; @@ -199,21 +162,18 @@ and 'x parameter_decl = { param_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x storage_decl = { kwd_storage : kwd_storage; store_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x operations_decl = { kwd_operations : kwd_operations; op_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig (* Type declarations *) @@ -224,79 +184,32 @@ and 'x type_decl = { type_expr : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x type_expr = - Prod of ('x cartesian, ttrue) gadt_if -| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if -| Record of ('x record_type, ttrue) gadt_if -| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if -| ParType of ('x type_expr par, ttrue) gadt_if -| TAlias of ('x variable, ttrue) gadt_if - -| Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if -| Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if -| Unit of (unit, 'type_expr_typecheck) gadt_if -constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; - .. > -constraint 'x = 'x x_sig - -(* -and 'x type_expr = ('x cartesian, - ('x variant, vbar) nsepseq reg, - 'x record_type, - ('x type_name * 'x type_tuple) reg, - 'x type_expr par, - 'x variable, - - ('x type_expr list) * 'x type_expr, - 'x type_expr, - unit, - - 'type_expr_parse, - 'type_expr_typecheck) type_expr_gadt -constraint 'x = < type_expr_parse: 'type_expr_parse; - type_expr_typecheck: 'type_expr_typecheck; - .. > -constraint 'x = 'x x_sig - -and ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'type_expr_parse, 'type_expr_typecheck) type_expr_gadt = - Prod : 'a -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt -| Sum : 'b -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt -| Record : 'c -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt -| TypeApp : 'd -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt -| ParType : 'e -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt -| TAlias : 'f -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, ttrue, ttrue) type_expr_gadt - -| Function : 'g -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt -| Mutable : 'h -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt -| Unit : 'i -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, tfalse, ttrue) type_expr_gadt - *) + Prod of 'x cartesian +| Sum of ('x variant, vbar) nsepseq reg +| Record of 'x record_type +| TypeApp of ('x type_name * 'x type_tuple) reg +| ParType of 'x type_expr par +| TAlias of 'x variable and 'x cartesian = ('x type_expr, times) nsepseq reg -constraint 'x = 'x x_sig and 'x variant = ('x constr * kwd_of * 'x cartesian) reg -constraint 'x = 'x x_sig and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg -constraint 'x = 'x x_sig and 'x field_decls = ('x field_decl, semi) nsepseq -constraint 'x = 'x x_sig and 'x field_decl = ('x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x type_tuple = ('x type_name, comma) nsepseq par -constraint 'x = 'x x_sig (* Function and procedure declarations *) and 'x lambda_decl = FunDecl of 'x fun_decl reg | ProcDecl of 'x proc_decl reg -constraint 'x = 'x x_sig and 'x fun_decl = { kwd_function : kwd_function; @@ -311,7 +224,6 @@ and 'x fun_decl = { return : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x proc_decl = { kwd_procedure : kwd_procedure; @@ -322,21 +234,16 @@ and 'x proc_decl = { block : 'x block reg; terminator : semi option } -constraint 'x = 'x x_sig and 'x parameters = ('x param_decl, semi) nsepseq par -constraint 'x = 'x x_sig and 'x param_decl = ParamConst of 'x param_const | ParamVar of 'x param_var -constraint 'x = 'x x_sig and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x block = { opening : kwd_begin; @@ -344,13 +251,11 @@ and 'x block = { terminator : semi option; close : kwd_end } -constraint 'x = 'x x_sig and 'x local_decl = LocalLam of 'x lambda_decl | LocalConst of 'x const_decl reg | LocalVar of 'x var_decl reg -constraint 'x = 'x x_sig and 'x const_decl = { kwd_const : kwd_const; @@ -361,7 +266,6 @@ and 'x const_decl = { init : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x var_decl = { kwd_var : kwd_var; @@ -372,15 +276,12 @@ and 'x var_decl = { init : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x instructions = ('x instruction, semi) nsepseq reg -constraint 'x = 'x x_sig and 'x instruction = Single of 'x single_instr | Block of 'x block reg -constraint 'x = 'x x_sig and 'x single_instr = Cond of 'x conditional reg @@ -390,7 +291,6 @@ and 'x single_instr = | ProcCall of 'x fun_call | Null of kwd_null | Fail of (kwd_fail * 'x expr) reg -constraint 'x = 'x x_sig and 'x conditional = { kwd_if : kwd_if; @@ -400,7 +300,6 @@ and 'x conditional = { kwd_else : kwd_else; ifnot : 'x instruction } -constraint 'x = 'x x_sig and 'x match_instr = { kwd_match : kwd_match; @@ -410,29 +309,22 @@ and 'x match_instr = { cases : 'x cases; kwd_end : kwd_end } -constraint 'x = 'x x_sig and 'x cases = ('x case, vbar) nsepseq reg -constraint 'x = 'x x_sig and 'x case = ('x pattern * arrow * 'x instruction) reg -constraint 'x = 'x x_sig and 'x ass_instr = ('x variable * ass * 'x expr) reg -constraint 'x = 'x x_sig and 'x loop = While of 'x while_loop | For of 'x for_loop -constraint 'x = 'x x_sig and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg -constraint 'x = 'x x_sig and 'x for_loop = ForInt of 'x for_int reg | ForCollect of 'x for_collect reg -constraint 'x = 'x x_sig and 'x for_int = { kwd_for : kwd_for; @@ -443,7 +335,6 @@ and 'x for_int = { step : (kwd_step * 'x expr) option; block : 'x block reg } -constraint 'x = 'x x_sig and 'x for_collect = { kwd_for : kwd_for; @@ -453,7 +344,6 @@ and 'x for_collect = { expr : 'x expr; block : 'x block reg } -constraint 'x = 'x x_sig (* Expressions *) @@ -493,43 +383,33 @@ and 'x expr = | SomeApp of (c_Some * 'x arguments) reg | MapLookUp of 'x map_lookup reg | ParExpr of 'x expr par -constraint 'x = 'x x_sig and 'x tuple = ('x expr, comma) nsepseq par -constraint 'x = 'x x_sig and 'x empty_list = (lbracket * rbracket * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x empty_set = (lbrace * rbrace * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x none_expr = (c_None * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x fun_call = ('x fun_name * 'x arguments) reg -constraint 'x = 'x x_sig and 'x arguments = 'x tuple -constraint 'x = 'x x_sig and 'x constr_app = ('x constr * 'x arguments) reg -constraint 'x = 'x x_sig and 'x map_lookup = { map_name : 'x variable; selector : dot; index : 'x expr brackets } -constraint 'x = 'x x_sig (* Patterns *) and 'x pattern = ('x core_pattern, cons) nsepseq reg -constraint 'x = 'x x_sig and 'x core_pattern = PVar of Lexer.lexeme reg @@ -544,39 +424,22 @@ and 'x core_pattern = | PSome of (c_Some * 'x core_pattern par) reg | PList of 'x list_pattern | PTuple of ('x core_pattern, comma) nsepseq par -constraint 'x = 'x x_sig and 'x list_pattern = Sugar of ('x core_pattern, comma) sepseq brackets | Raw of ('x core_pattern * cons * 'x pattern) par -constraint 'x = 'x x_sig - -(* Variations on the AST *) - -type parse_phase = < - annot: unit; - type_expr_typecheck: tfalse; -> - -type typecheck_phase = < - annot: typecheck_phase type_expr; - type_expr_typecheck: ttrue; -> - -type t = parse_phase ast (* Projecting regions *) open! Region -let type_expr_to_region : parse_phase type_expr -> region = function - Prod (Present node) -> node.region -| Sum (Present node) -> node.region -| Record (Present node) -> node.region -| TypeApp (Present node) -> node.region -| ParType (Present node) -> node.region -| TAlias (Present node) -> node.region -| _ -> . +let type_expr_to_region = function + Prod node -> node.region +| Sum node -> node.region +| Record node -> node.region +| TypeApp node -> node.region +| ParType node -> node.region +| TAlias node -> node.region let expr_to_region = function Or {region; _} diff --git a/AST.mli b/AST.mli index d89d92b25..cb6fbcd2b 100644 --- a/AST.mli +++ b/AST.mli @@ -126,45 +126,9 @@ type 'a braces = (lbrace * 'a * rbrace) reg (* The Abstract Syntax Tree *) -type ttrue = TTrue -type tfalse = TFalse -type ('a, 'type_expr_typecheck) gadt_if = - Present : 'a -> ('a, ttrue) gadt_if +type t = < ty:unit > ast -(* It is possible to further ensure well-typedness at the meta level - by using the following constraint: - - type ttrue = [`True] - type tfalse = [`False] - - type 'x x_sig = 'x - constraint 'x = < annot: 'ty; - type_expr_typecheck: [< `True | `False] > - - we could also use a single selector for type_expr, as long as - the fields are monotonic: - - type z = [`Z] - type 'i s = [`S of 'i] - type 'is type_level_int = [< `S of 'i | `Z] - constraint 'i = 'prev type_level_int - - type parse_phase = z - type typecheck_phase = z s - type further_phase = z s s - - type 'x x_sig = 'x - constraint 'x = < annot: 'ty; - type_expr: 'type_expr > - - These schemes provide more guidance but the simple one below is - sufficient. - *) -type 'x x_sig = 'x -constraint 'x = < annot: 'type_annotation; - type_expr_typecheck: 'bool1 > - -type 'x ast = { +and 'x ast = { types : 'x type_decl reg list; constants : 'x const_decl reg list; parameter : 'x parameter_decl reg; @@ -174,7 +138,6 @@ type 'x ast = { block : 'x block reg; eof : eof } -constraint 'x = 'x x_sig and 'x parameter_decl = { kwd_parameter : kwd_parameter; @@ -183,21 +146,18 @@ and 'x parameter_decl = { param_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x storage_decl = { kwd_storage : kwd_storage; store_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x operations_decl = { kwd_operations : kwd_operations; op_type : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig (* Type declarations *) @@ -208,47 +168,32 @@ and 'x type_decl = { type_expr : 'x type_expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x type_expr = - Prod of ('x cartesian, ttrue) gadt_if -| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if -| Record of ('x record_type, ttrue) gadt_if -| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if -| ParType of ('x type_expr par, ttrue) gadt_if -| TAlias of ('x variable, ttrue) gadt_if - -| Function of (('x type_expr list) * 'x type_expr, 'type_expr_typecheck) gadt_if -| Mutable of ('x type_expr, 'type_expr_typecheck) gadt_if -| Unit of (unit, 'type_expr_typecheck) gadt_if -constraint 'x = < type_expr_typecheck: 'type_expr_typecheck; - .. > -constraint 'x = 'x x_sig + Prod of 'x cartesian +| Sum of ('x variant, vbar) nsepseq reg +| Record of 'x record_type +| TypeApp of ('x type_name * 'x type_tuple) reg +| ParType of 'x type_expr par +| TAlias of 'x variable and 'x cartesian = ('x type_expr, times) nsepseq reg -constraint 'x = 'x x_sig and 'x variant = ('x constr * kwd_of * 'x cartesian) reg -constraint 'x = 'x x_sig and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg -constraint 'x = 'x x_sig and 'x field_decls = ('x field_decl, semi) nsepseq -constraint 'x = 'x x_sig and 'x field_decl = ('x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x type_tuple = ('x type_name, comma) nsepseq par -constraint 'x = 'x x_sig (* Function and procedure declarations *) and 'x lambda_decl = FunDecl of 'x fun_decl reg | ProcDecl of 'x proc_decl reg -constraint 'x = 'x x_sig and 'x fun_decl = { kwd_function : kwd_function; @@ -263,7 +208,6 @@ and 'x fun_decl = { return : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x proc_decl = { kwd_procedure : kwd_procedure; @@ -274,21 +218,16 @@ and 'x proc_decl = { block : 'x block reg; terminator : semi option } -constraint 'x = 'x x_sig and 'x parameters = ('x param_decl, semi) nsepseq par -constraint 'x = 'x x_sig and 'x param_decl = ParamConst of 'x param_const | ParamVar of 'x param_var -constraint 'x = 'x x_sig and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg -constraint 'x = 'x x_sig and 'x block = { opening : kwd_begin; @@ -296,13 +235,11 @@ and 'x block = { terminator : semi option; close : kwd_end } -constraint 'x = 'x x_sig and 'x local_decl = LocalLam of 'x lambda_decl | LocalConst of 'x const_decl reg | LocalVar of 'x var_decl reg -constraint 'x = 'x x_sig and 'x const_decl = { kwd_const : kwd_const; @@ -313,7 +250,6 @@ and 'x const_decl = { init : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x var_decl = { kwd_var : kwd_var; @@ -324,15 +260,12 @@ and 'x var_decl = { init : 'x expr; terminator : semi option } -constraint 'x = 'x x_sig and 'x instructions = ('x instruction, semi) nsepseq reg -constraint 'x = 'x x_sig and 'x instruction = Single of 'x single_instr | Block of 'x block reg -constraint 'x = 'x x_sig and 'x single_instr = Cond of 'x conditional reg @@ -342,7 +275,6 @@ and 'x single_instr = | ProcCall of 'x fun_call | Null of kwd_null | Fail of (kwd_fail * 'x expr) reg -constraint 'x = 'x x_sig and 'x conditional = { kwd_if : kwd_if; @@ -352,7 +284,6 @@ and 'x conditional = { kwd_else : kwd_else; ifnot : 'x instruction } -constraint 'x = 'x x_sig and 'x match_instr = { kwd_match : kwd_match; @@ -362,29 +293,22 @@ and 'x match_instr = { cases : 'x cases; kwd_end : kwd_end } -constraint 'x = 'x x_sig and 'x cases = ('x case, vbar) nsepseq reg -constraint 'x = 'x x_sig and 'x case = ('x pattern * arrow * 'x instruction) reg -constraint 'x = 'x x_sig and 'x ass_instr = ('x variable * ass * 'x expr) reg -constraint 'x = 'x x_sig and 'x loop = While of 'x while_loop | For of 'x for_loop -constraint 'x = 'x x_sig and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg -constraint 'x = 'x x_sig and 'x for_loop = ForInt of 'x for_int reg | ForCollect of 'x for_collect reg -constraint 'x = 'x x_sig and 'x for_int = { kwd_for : kwd_for; @@ -395,7 +319,6 @@ and 'x for_int = { step : (kwd_step * 'x expr) option; block : 'x block reg } -constraint 'x = 'x x_sig and 'x for_collect = { kwd_for : kwd_for; @@ -405,7 +328,6 @@ and 'x for_collect = { expr : 'x expr; block : 'x block reg } -constraint 'x = 'x x_sig (* Expressions *) @@ -445,43 +367,33 @@ and 'x expr = | SomeApp of (c_Some * 'x arguments) reg | MapLookUp of 'x map_lookup reg | ParExpr of 'x expr par -constraint 'x = 'x x_sig and 'x tuple = ('x expr, comma) nsepseq par -constraint 'x = 'x x_sig and 'x empty_list = (lbracket * rbracket * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x empty_set = (lbrace * rbrace * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x none_expr = (c_None * colon * 'x type_expr) par -constraint 'x = 'x x_sig and 'x fun_call = ('x fun_name * 'x arguments) reg -constraint 'x = 'x x_sig and 'x arguments = 'x tuple -constraint 'x = 'x x_sig and 'x constr_app = ('x constr * 'x arguments) reg -constraint 'x = 'x x_sig and 'x map_lookup = { map_name : 'x variable; selector : dot; index : 'x expr brackets } -constraint 'x = 'x x_sig (* Patterns *) and 'x pattern = ('x core_pattern, cons) nsepseq reg -constraint 'x = 'x x_sig and 'x core_pattern = PVar of Lexer.lexeme reg @@ -496,30 +408,14 @@ and 'x core_pattern = | PSome of (c_Some * 'x core_pattern par) reg | PList of 'x list_pattern | PTuple of ('x core_pattern, comma) nsepseq par -constraint 'x = 'x x_sig and 'x list_pattern = Sugar of ('x core_pattern, comma) sepseq brackets | Raw of ('x core_pattern * cons * 'x pattern) par -constraint 'x = 'x x_sig - -(* Variations on the AST *) - -type parse_phase = < - annot: unit; - type_expr_typecheck: tfalse; -> - -type typecheck_phase = < - annot: typecheck_phase type_expr; - type_expr_typecheck: ttrue; -> - -type t = parse_phase ast (* Projecting regions *) -val type_expr_to_region : parse_phase type_expr -> Region.t +val type_expr_to_region : 'x type_expr -> Region.t val expr_to_region : 'x expr -> Region.t diff --git a/Parser.mly b/Parser.mly index 547e20e68..d3aca6dcc 100644 --- a/Parser.mly +++ b/Parser.mly @@ -171,9 +171,9 @@ type_decl: in {region; value}} type_expr: - cartesian { Prod (Present $1) } -| sum_type { Sum (Present $1) } -| record_type { Record (Present $1) } + cartesian { Prod $1 } +| sum_type { Sum $1 } +| record_type { Record $1 } cartesian: nsepseq(core_type,TIMES) { @@ -183,14 +183,14 @@ cartesian: core_type: type_name { - TAlias (Present $1) + TAlias $1 } | type_name type_tuple { let region = cover $1.region $2.region - in TypeApp (Present {region; value = $1,$2}) + in TypeApp {region; value = $1,$2} } | par(type_expr) { - ParType (Present $1) + ParType $1 } type_tuple: diff --git a/ParserMain.ml b/ParserMain.ml index c23833c25..0c940bfb6 100644 --- a/ParserMain.ml +++ b/ParserMain.ml @@ -57,10 +57,8 @@ let tokeniser = read ~log let () = try let ast = Parser.program tokeniser buffer in - let () = if Utils.String.Set.mem "parser" EvalOpt.verbose - then Print.print_tokens ast in - let _ = Typecheck2.tc_ast ast - in () + if Utils.String.Set.mem "parser" EvalOpt.verbose + then Print.print_tokens ast with Lexer.Error err -> close_all (); diff --git a/Print.ml b/Print.ml index 389a1f54d..c41da7f0a 100644 --- a/Print.ml +++ b/Print.ml @@ -47,7 +47,7 @@ and print_int _visitor {region; value = lexeme, abstract} = (* Main printing function *) -and print_tokens : 'x visitor -> 'x ast -> unit = fun v ast -> +and print_tokens (v: 'x visitor) ast = List.iter v.type_decl ast.types; v.parameter_decl ast.parameter; v.storage_decl ast.storage; @@ -56,90 +56,87 @@ and print_tokens : 'x visitor -> 'x ast -> unit = fun v ast -> v.block ast.block; v.token ast.eof "EOF" -and print_parameter_decl (v : 'xvisitor) {value=node; _} = +and print_parameter_decl (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_storage_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_storage "storage"; v.type_expr node.store_type; v.terminator node.terminator -and print_operations_decl (v : 'xvisitor) {value=node; _} = +and print_operations_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_operations "operations"; v.type_expr node.op_type; v.terminator node.terminator -and print_type_decl (v : 'xvisitor) {value=node; _} = +and print_type_decl (v: 'x 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 : 'xvisitor) = function - Prod (Present cartesian) -> v.cartesian cartesian -| Sum (Present sum_type) -> v.sum_type sum_type -| Record (Present record_type) -> v.record_type record_type -| TypeApp (Present type_app) -> v.type_app type_app -| ParType (Present par_type) -> v.par_type par_type -| TAlias (Present type_alias) -> v.var type_alias -| Function _function' -> printf "TODO" -| Mutable _mutable' -> printf "TODO" -| Unit _unit' -> printf "TODO" +and print_type_expr (v: 'x 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 : 'xvisitor) {value=sequence; _} = +and print_cartesian (v: 'x visitor) {value=sequence; _} = v.nsepseq "*" v.type_expr sequence -and print_variant (v : 'xvisitor) {value=node; _} = +and print_variant (v: 'x 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 : 'xvisitor) {value=sequence; _} = +and print_sum_type (v: 'x visitor) {value=sequence; _} = v.nsepseq "|" v.variant sequence -and print_record_type (v : 'xvisitor) {value=node; _} = +and print_record_type (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_type_app (v: 'x visitor) {value=node; _} = let type_name, type_tuple = node in v.var type_name; v.type_tuple type_tuple -and print_par_type (v : 'xvisitor) {value=node; _} = +and print_par_type (v: 'x 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 : 'xvisitor) sequence = +and print_field_decls (v: 'x visitor) sequence = v.nsepseq ";" v.field_decl sequence -and print_field_decl (v : 'xvisitor) {value=node; _} = +and print_field_decl (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_type_tuple (v: 'x 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 : 'xvisitor) = function +and print_lambda_decl (v: 'x visitor) = function FunDecl fun_decl -> v.fun_decl fun_decl | ProcDecl proc_decl -> v.proc_decl proc_decl -and print_fun_decl (v : 'xvisitor) {value=node; _} = +and print_fun_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_function "function"; v.var node.name; v.parameters node.param; @@ -152,7 +149,7 @@ and print_fun_decl (v : 'xvisitor) {value=node; _} = v.expr node.return; v.terminator node.terminator -and print_proc_decl (v : 'xvisitor) {value=node; _} = +and print_proc_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_procedure "procedure"; v.var node.name; v.parameters node.param; @@ -161,45 +158,45 @@ and print_proc_decl (v : 'xvisitor) {value=node; _} = v.block node.block; v.terminator node.terminator -and print_parameters (v : 'xvisitor) {value=node; _} = +and print_parameters (v: 'x 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 : 'xvisitor) = function +and print_param_decl (v: 'x visitor) = function ParamConst param_const -> v.param_const param_const | ParamVar param_var -> v.param_var param_var -and print_param_const (v : 'xvisitor) {value=node; _} = +and print_param_const (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_param_var (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_block (v: 'x 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 : 'xvisitor) sequence = +and print_local_decls (v: 'x visitor) sequence = List.iter v.local_decl sequence -and print_local_decl (v : 'xvisitor) = function +and print_local_decl (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_const_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_const "const"; v.var node.name; v.token node.colon ":"; @@ -208,7 +205,7 @@ and print_const_decl (v : 'xvisitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_var_decl (v : 'xvisitor) {value=node; _} = +and print_var_decl (v: 'x visitor) {value=node; _} = v.token node.kwd_var "var"; v.var node.name; v.token node.colon ":"; @@ -217,14 +214,14 @@ and print_var_decl (v : 'xvisitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_instructions (v : 'xvisitor) {value=sequence; _} = +and print_instructions (v: 'x visitor) {value=sequence; _} = v.nsepseq ";" v.instruction sequence -and print_instruction (v : 'xvisitor) = function +and print_instruction (v: 'x visitor) = function Single instr -> v.single_instr instr | Block block -> v.block block -and print_single_instr (v : 'xvisitor) = function +and print_single_instr (v: 'x visitor) = function Cond {value; _} -> v.conditional value | Match {value; _} -> v.match_instr value | Ass instr -> v.ass_instr instr @@ -233,11 +230,11 @@ and print_single_instr (v : 'xvisitor) = function | Null kwd_null -> v.token kwd_null "null" | Fail {value; _} -> v.fail value -and print_fail (v : 'xvisitor) (kwd_fail, expr) = +and print_fail (v: 'x visitor) (kwd_fail, expr) = v.token kwd_fail "fail"; v.expr expr -and print_conditional (v : 'xvisitor) node = +and print_conditional (v: 'x visitor) node = v.token node.kwd_if "if"; v.expr node.test; v.token node.kwd_then "then"; @@ -245,43 +242,43 @@ and print_conditional (v : 'xvisitor) node = v.token node.kwd_else "else"; v.instruction node.ifnot -and print_match_instr (v : 'xvisitor) node = +and print_match_instr (v: 'x 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 : 'xvisitor) {value=sequence; _} = +and print_cases (v: 'x visitor) {value=sequence; _} = v.nsepseq "|" v.case sequence -and print_case (v : 'xvisitor) {value=node; _} = +and print_case (v: 'x visitor) {value=node; _} = let pattern, arrow, instruction = node in v.pattern pattern; v.token arrow "->"; v.instruction instruction -and print_ass_instr (v : 'xvisitor) {value=node; _} = +and print_ass_instr (v: 'x visitor) {value=node; _} = let variable, ass, expr = node in v.var variable; v.token ass ":="; v.expr expr -and print_loop (v : 'xvisitor) = function +and print_loop (v: 'x visitor) = function While while_loop -> v.while_loop while_loop | For for_loop -> v.for_loop for_loop -and print_while_loop (v : 'xvisitor) {value=node; _} = +and print_while_loop (v: 'x 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 : 'xvisitor) = function +and print_for_loop (v: 'x visitor) = function ForInt for_int -> v.for_int for_int | ForCollect for_collect -> v.for_collect for_collect -and print_for_int (v : 'xvisitor) ({value=node; _} : 'x for_int reg) = +and print_for_int (v: 'x visitor) ({value=node; _} : 'x for_int reg) = v.token node.kwd_for "for"; v.ass_instr node.ass; v.down node.down; @@ -290,17 +287,17 @@ and print_for_int (v : 'xvisitor) ({value=node; _} : 'x for_int reg) = v.step node.step; v.block node.block -and print_down (v : 'xvisitor) = function +and print_down (v: 'x visitor) = function Some kwd_down -> v.token kwd_down "down" | None -> () -and print_step (v : 'xvisitor) = function +and print_step (v: 'x visitor) = function Some (kwd_step, expr) -> v.token kwd_step "step"; v.expr expr | None -> () -and print_for_collect (v : 'xvisitor) ({value=node; _} : 'x for_collect reg) = +and print_for_collect (v: 'x visitor) ({value=node; _} : 'x for_collect reg) = v.token node.kwd_for "for"; v.var node.var; v.bind_to node.bind_to; @@ -308,13 +305,13 @@ and print_for_collect (v : 'xvisitor) ({value=node; _} : 'x for_collect reg) = v.expr node.expr; v.block node.block -and print_bind_to (v : 'xvisitor) = function +and print_bind_to (v: 'x visitor) = function Some (arrow, variable) -> v.token arrow "->"; v.var variable | None -> () -and print_expr (v : 'xvisitor) = function +and print_expr (v: 'x visitor) = function Or {value = expr1, bool_or, expr2; _} -> v.expr expr1; v.token bool_or "||"; v.expr expr2 | And {value = expr1, bool_and, expr2; _} -> @@ -368,19 +365,19 @@ and print_expr (v : 'xvisitor) = function | MapLookUp lookup -> v.map_lookup lookup | ParExpr pexpr -> v.par_expr pexpr -and print_tuple (v : 'xvisitor) {value=node; _} = +and print_tuple (v: 'x visitor) {value=node; _} = let lpar, sequence, rpar = node in v.token lpar "("; v.nsepseq "," v.expr sequence; v.token rpar ")" -and print_list (v : 'xvisitor) {value=node; _} = +and print_list (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_empty_list (v: 'x visitor) {value=node; _} = let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in v.token lpar "("; v.token lbracket "["; @@ -389,13 +386,13 @@ and print_empty_list (v : 'xvisitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_set (v : 'xvisitor) {value=node; _} = +and print_set (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_empty_set (v: 'x visitor) {value=node; _} = let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in v.token lpar "("; v.token lbrace "{"; @@ -404,7 +401,7 @@ and print_empty_set (v : 'xvisitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_none_expr (v : 'xvisitor) {value=node; _} = +and print_none_expr (v: 'x visitor) {value=node; _} = let lpar, (c_None, colon, type_expr), rpar = node in v.token lpar "("; v.token c_None "None"; @@ -412,22 +409,22 @@ and print_none_expr (v : 'xvisitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_fun_call (v : 'xvisitor) {value=node; _} = +and print_fun_call (v: 'x visitor) {value=node; _} = let fun_name, arguments = node in v.var fun_name; v.tuple arguments -and print_constr_app (v : 'xvisitor) {value=node; _} = +and print_constr_app (v: 'x visitor) {value=node; _} = let constr, arguments = node in v.constr constr; v.tuple arguments -and print_some_app (v : 'xvisitor) {value=node; _} = +and print_some_app (v: 'x visitor) {value=node; _} = let c_Some, arguments = node in v.token c_Some "Some"; v.tuple arguments -and print_map_lookup (v : 'xvisitor) {value=node; _} = +and print_map_lookup (v: 'x visitor) {value=node; _} = let {value = lbracket, expr, rbracket; _} = node.index in v.var node.map_name; v.token node.selector "."; @@ -435,16 +432,16 @@ and print_map_lookup (v : 'xvisitor) {value=node; _} = v.expr expr; v.token rbracket "]" -and print_par_expr (v : 'xvisitor) {value=node; _} = +and print_par_expr (v: 'x visitor) {value=node; _} = let lpar, expr, rpar = node in v.token lpar "("; v.expr expr; v.token rpar ")" -and print_pattern (v : 'xvisitor) {value=sequence; _} = +and print_pattern (v: 'x visitor) {value=sequence; _} = v.nsepseq "<:" v.core_pattern sequence -and print_core_pattern (v : 'xvisitor) = function +and print_core_pattern (v: 'x visitor) = function PVar var -> v.var var | PWild wild -> v.token wild "_" | PInt i -> v.int i @@ -458,28 +455,28 @@ and print_core_pattern (v : 'xvisitor) = function | PList pattern -> v.list_pattern pattern | PTuple ptuple -> v.ptuple ptuple -and print_psome (v : 'xvisitor) {value=node; _} = +and print_psome (v: 'x visitor) {value=node; _} = let c_Some, patterns = node in v.token c_Some "Some"; v.patterns patterns -and print_patterns (v : 'xvisitor) {value=node; _} = +and print_patterns (v: 'x 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 : 'xvisitor) = function +and print_list_pattern (v: 'x visitor) = function Sugar sugar -> v.sugar sugar | Raw raw -> v.raw raw -and print_sugar (v : 'xvisitor) {value=node; _} = +and print_sugar (v: 'x 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 : 'xvisitor) {value=node; _} = +and print_raw (v: 'x visitor) {value=node; _} = let lpar, (core_pattern, cons, pattern), rpar = node in v.token lpar "("; v.core_pattern core_pattern; @@ -487,13 +484,13 @@ and print_raw (v : 'xvisitor) {value=node; _} = v.pattern pattern; v.token rpar ")" -and print_ptuple (v : 'xvisitor) {value=node; _} = +and print_ptuple (v: 'x 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 : 'xvisitor) = function +and print_terminator (v: 'x visitor) = function Some semi -> v.token semi ";" | None -> () diff --git a/Print.mli b/Print.mli index 97621a8fc..66fae6dfa 100644 --- a/Print.mli +++ b/Print.mli @@ -2,4 +2,4 @@ open AST -val print_tokens : parse_phase ast -> unit +val print_tokens : t -> unit diff --git a/Typecheck2.ml b/Typecheck2.ml deleted file mode 100644 index ae5d9bdb3..000000000 --- a/Typecheck2.ml +++ /dev/null @@ -1,337 +0,0 @@ -module SMap = Map.Make(String) - -open AST - -type i = parse_phase -type typecheck_phase = < - annot: typecheck_phase type_expr; - type_expr_typecheck: tfalse; -> -type o = typecheck_phase - -type te = o type_expr list SMap.t (* Type environment *) -type ve = o type_expr list SMap.t (* Value environment *) -type tve = te * ve - -let id (ast : i ast) : o ast = {ast with eof = ast.eof} - -(* Utilities *) - -let fold_map f a l = - let f (acc, l) elem = - let acc', elem' = f acc elem - in acc', (elem' :: l) in - let last_acc, last_l = List.fold_left f (a, []) l - in last_acc, List.rev last_l - -let reg ({value;region} : 'a reg) (f : 'a -> 'b) : 'b reg = {value = f value; region} -let unreg ({value;_} : 'a reg) : 'a = value - -(* Typecheck *) - -let tc_type_decl (te, ve : tve) (td : i type_decl reg) : tve * o type_decl reg = - (te, ve), (unreg td) - -let tc_types (tve : tve) (types : i type_decl reg list) = - fold_map tc_type_decl tve types - -let tc_ast (tve : tve) (ast : i ast) = - let {types;constants;parameter;storage;operations;lambdas;block;eof} = ast in - let tve, types = tc_types tve types in - let ast = {types;constants;parameter;storage;operations;lambdas;block;eof} in - tve, ast - -let tc_ast ast = - let tve, ast = tc_ast (SMap.empty, SMap.empty) ast in - let _ = tve in (* Drop the final type and value environment *) - ast - -(* -open Region -open Utils -type new_t = < ty: int > 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 'a parameter_decl = { - kwd_parameter : kwd_parameter; - name : 'a variable; - colon : colon; - param_type : 'a type_expr; - terminator : semi option -} - -and 'a storage_decl = { - kwd_storage : kwd_storage; - store_type : 'a type_expr; - terminator : semi option -} - -and 'a operations_decl = { - kwd_operations : kwd_operations; - op_type : 'a 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 '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 'a cartesian = ('a type_expr, times) nsepseq reg - -and 'a variant = ('a constr * kwd_of * 'a cartesian) reg - -and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg - -and 'a field_decls = ('a field_decl, semi) nsepseq - -and 'a field_decl = ('a variable * colon * 'a type_expr) reg - -and 'a type_tuple = ('a 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 '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 '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 'a parameters = ('a param_decl, semi) nsepseq par - -and 'a param_decl = - ParamConst of 'a param_const -| ParamVar of 'a param_var - -and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg - -and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg - -and 'a block = { - opening : kwd_begin; - instr : 'a 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 '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 '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 'a instructions = ('a instruction, semi) nsepseq reg - -and 'a instruction = - Single of 'a single_instr -| Block of 'a 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 -| Null of kwd_null -| Fail of (kwd_fail * 'a 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 '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 'a cases = ('a case, vbar) nsepseq reg - -and 'a case = ('a pattern * arrow * 'a instruction) reg - -and 'a ass_instr = ('a variable * ass * 'a expr) reg - -and 'a loop = - While of 'a while_loop -| For of 'a for_loop - -and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg - -and 'a for_loop = - ForInt of 'a for_int reg -| ForCollect of 'a 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 '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 '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 -| Bytes of (Lexer.lexeme * MBytes.t) reg -| 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 - -and 'a tuple = ('a expr, comma) nsepseq par - -and 'a empty_list = - (lbracket * rbracket * colon * 'a type_expr) par - -and 'a empty_set = - (lbrace * rbrace * colon * 'a type_expr) par - -and 'a none_expr = - (c_None * colon * 'a type_expr) par - -and 'a fun_call = ('a fun_name * 'a arguments) reg - -and 'a arguments = 'a tuple - -and 'a constr_app = ('a constr * 'a arguments) reg - -and 'a map_lookup = { - map_name : 'a variable; - selector : dot; - index : 'a expr brackets -} - -(* Patterns *) - -and 'a pattern = ('a core_pattern, cons) nsepseq reg - -and 'a core_pattern = - PVar of Lexer.lexeme reg -| PWild of wild -| PInt of (Lexer.lexeme * Z.t) reg -| PBytes of (Lexer.lexeme * MBytes.t) reg -| PString of Lexer.lexeme reg -| PUnit of c_Unit -| PFalse of c_False -| PTrue of c_True -| PNone of c_None -| PSome of (c_Some * 'a core_pattern par) reg -| PList of 'a list_pattern -| PTuple of ('a 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 - *) diff --git a/Typecheck2.mli b/Typecheck2.mli deleted file mode 100644 index 8f5bf59e1..000000000 --- a/Typecheck2.mli +++ /dev/null @@ -1 +0,0 @@ -val tc_ast : AST.parse_phase AST.ast -> AST.typecheck_phase AST.ast diff --git a/typecheck.ml b/typecheck.ml index dc2bc374a..b768a9949 100644 --- a/typecheck.ml +++ b/typecheck.ml @@ -1,3 +1,8 @@ + + + + + (* module I = AST (* In *) From b5f7779a68e6b89110da0222216a2aa2f900e339 Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 21:00:48 +0100 Subject: [PATCH 7/8] Revert "Renamed the extensibility type parameter to 'x so that it can easily be grepped for." This reverts commit fb85ea1f18e7f29460f62deaa1abc0d2e5d37d1a. --- AST.ml | 450 ++++++++++++++++++++++++++--------------------------- AST.mli | 464 +++++++++++++++++++++++++++---------------------------- Print.ml | 132 ++++++++-------- 3 files changed, 523 insertions(+), 523 deletions(-) diff --git a/AST.ml b/AST.ml index 940b562c4..c9596c183 100644 --- a/AST.ml +++ b/AST.ml @@ -113,12 +113,12 @@ type eof = Region.t (* Literals *) -type 'x variable = string reg -type 'x fun_name = string reg -type 'x type_name = string reg -type 'x field_name = string reg -type 'x map_name = string reg -type 'x 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 *) @@ -144,227 +144,227 @@ type 'a braces = (lbrace * 'a * rbrace) reg type t = < ty: unit > ast -and 'x ast = { - types : 'x type_decl reg list; - constants : 'x const_decl reg list; - parameter : 'x parameter_decl reg; - storage : 'x storage_decl reg; - operations : 'x operations_decl reg; - lambdas : 'x lambda_decl list; - block : 'x block reg; +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 'x parameter_decl = { +and 'a parameter_decl = { kwd_parameter : kwd_parameter; - name : 'x variable; + name : 'a variable; colon : colon; - param_type : 'x type_expr; + param_type : 'a type_expr; terminator : semi option } -and 'x storage_decl = { +and 'a storage_decl = { kwd_storage : kwd_storage; - store_type : 'x type_expr; + store_type : 'a type_expr; terminator : semi option } -and 'x operations_decl = { +and 'a operations_decl = { kwd_operations : kwd_operations; - op_type : 'x type_expr; + op_type : 'a type_expr; terminator : semi option } (* Type declarations *) -and 'x type_decl = { +and 'a type_decl = { kwd_type : kwd_type; - name : 'x type_name; + name : 'a type_name; kwd_is : kwd_is; - type_expr : 'x type_expr; + type_expr : 'a type_expr; terminator : semi option } -and 'x type_expr = - Prod of 'x cartesian -| Sum of ('x variant, vbar) nsepseq reg -| Record of 'x record_type -| TypeApp of ('x type_name * 'x type_tuple) reg -| ParType of 'x type_expr par -| TAlias of 'x 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 'x cartesian = ('x type_expr, times) nsepseq reg +and 'a cartesian = ('a type_expr, times) nsepseq reg -and 'x variant = ('x constr * kwd_of * 'x cartesian) reg +and 'a variant = ('a constr * kwd_of * 'a cartesian) reg -and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg +and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg -and 'x field_decls = ('x field_decl, semi) nsepseq +and 'a field_decls = ('a field_decl, semi) nsepseq -and 'x field_decl = ('x variable * colon * 'x type_expr) reg +and 'a field_decl = ('a variable * colon * 'a type_expr) reg -and 'x type_tuple = ('x type_name, comma) nsepseq par +and 'a type_tuple = ('a type_name, comma) nsepseq par (* Function and procedure declarations *) -and 'x lambda_decl = - FunDecl of 'x fun_decl reg -| ProcDecl of 'x proc_decl reg +and 'a lambda_decl = + FunDecl of 'a fun_decl reg +| ProcDecl of 'a proc_decl reg -and 'x fun_decl = { +and 'a fun_decl = { kwd_function : kwd_function; - name : 'x variable; - param : 'x parameters; + name : 'a variable; + param : 'a parameters; colon : colon; - ret_type : 'x type_expr; + ret_type : 'a type_expr; kwd_is : kwd_is; - local_decls : 'x local_decl list; - block : 'x block reg; + local_decls : 'a local_decl list; + block : 'a block reg; kwd_with : kwd_with; - return : 'x expr; + return : 'a expr; terminator : semi option } -and 'x proc_decl = { +and 'a proc_decl = { kwd_procedure : kwd_procedure; - name : 'x variable; - param : 'x parameters; + name : 'a variable; + param : 'a parameters; kwd_is : kwd_is; - local_decls : 'x local_decl list; - block : 'x block reg; + local_decls : 'a local_decl list; + block : 'a block reg; terminator : semi option } -and 'x parameters = ('x param_decl, semi) nsepseq par +and 'a parameters = ('a param_decl, semi) nsepseq par -and 'x param_decl = - ParamConst of 'x param_const -| ParamVar of 'x param_var +and 'a param_decl = + ParamConst of 'a param_const +| ParamVar of 'a param_var -and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg +and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg -and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg +and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg -and 'x block = { +and 'a block = { opening : kwd_begin; - instr : 'x instructions; + instr : 'a instructions; terminator : semi option; close : kwd_end } -and 'x local_decl = - LocalLam of 'x lambda_decl -| LocalConst of 'x const_decl reg -| LocalVar of 'x 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 'x const_decl = { +and 'a const_decl = { kwd_const : kwd_const; - name : 'x variable; + name : 'a variable; colon : colon; - vtype : 'x type_expr; + vtype : 'a type_expr; equal : equal; - init : 'x expr; + init : 'a expr; terminator : semi option } -and 'x var_decl = { +and 'a var_decl = { kwd_var : kwd_var; - name : 'x variable; + name : 'a variable; colon : colon; - vtype : 'x type_expr; + vtype : 'a type_expr; ass : ass; - init : 'x expr; + init : 'a expr; terminator : semi option } -and 'x instructions = ('x instruction, semi) nsepseq reg +and 'a instructions = ('a instruction, semi) nsepseq reg -and 'x instruction = - Single of 'x single_instr -| Block of 'x block reg +and 'a instruction = + Single of 'a single_instr +| Block of 'a block reg -and 'x single_instr = - Cond of 'x conditional reg -| Match of 'x match_instr reg -| Ass of 'x ass_instr -| Loop of 'x loop -| ProcCall of 'x 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 * 'x expr) reg +| Fail of (kwd_fail * 'a expr) reg -and 'x conditional = { +and 'a conditional = { kwd_if : kwd_if; - test : 'x expr; + test : 'a expr; kwd_then : kwd_then; - ifso : 'x instruction; + ifso : 'a instruction; kwd_else : kwd_else; - ifnot : 'x instruction + ifnot : 'a instruction } -and 'x match_instr = { +and 'a match_instr = { kwd_match : kwd_match; - expr : 'x expr; + expr : 'a expr; kwd_with : kwd_with; lead_vbar : vbar option; - cases : 'x cases; + cases : 'a cases; kwd_end : kwd_end } -and 'x cases = ('x case, vbar) nsepseq reg +and 'a cases = ('a case, vbar) nsepseq reg -and 'x case = ('x pattern * arrow * 'x instruction) reg +and 'a case = ('a pattern * arrow * 'a instruction) reg -and 'x ass_instr = ('x variable * ass * 'x expr) reg +and 'a ass_instr = ('a variable * ass * 'a expr) reg -and 'x loop = - While of 'x while_loop -| For of 'x for_loop +and 'a loop = + While of 'a while_loop +| For of 'a for_loop -and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg +and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg -and 'x for_loop = - ForInt of 'x for_int reg -| ForCollect of 'x for_collect reg +and 'a for_loop = + ForInt of 'a for_int reg +| ForCollect of 'a for_collect reg -and 'x for_int = { +and 'a for_int = { kwd_for : kwd_for; - ass : 'x ass_instr; + ass : 'a ass_instr; down : kwd_down option; kwd_to : kwd_to; - bound : 'x expr; - step : (kwd_step * 'x expr) option; - block : 'x block reg + bound : 'a expr; + step : (kwd_step * 'a expr) option; + block : 'a block reg } -and 'x for_collect = { +and 'a for_collect = { kwd_for : kwd_for; - var : 'x variable; - bind_to : (arrow * 'x variable) option; + var : 'a variable; + bind_to : (arrow * 'a variable) option; kwd_in : kwd_in; - expr : 'x expr; - block : 'x block reg + expr : 'a expr; + block : 'a block reg } (* Expressions *) -and 'x expr = - Or of ('x expr * bool_or * 'x expr) reg -| And of ('x expr * bool_and * 'x expr) reg -| Lt of ('x expr * lt * 'x expr) reg -| Leq of ('x expr * leq * 'x expr) reg -| Gt of ('x expr * gt * 'x expr) reg -| Geq of ('x expr * geq * 'x expr) reg -| Equal of ('x expr * equal * 'x expr) reg -| Neq of ('x expr * neq * 'x expr) reg -| Cat of ('x expr * cat * 'x expr) reg -| Cons of ('x expr * cons * 'x expr) reg -| Add of ('x expr * plus * 'x expr) reg -| Sub of ('x expr * minus * 'x expr) reg -| Mult of ('x expr * times * 'x expr) reg -| Div of ('x expr * slash * 'x expr) reg -| Mod of ('x expr * kwd_mod * 'x expr) reg -| Neg of (minus * 'x expr) reg -| Not of (kwd_not * 'x 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 @@ -372,46 +372,46 @@ and 'x expr = | False of c_False | True of c_True | Unit of c_Unit -| Tuple of 'x tuple -| List of ('x expr, comma) nsepseq brackets -| EmptyList of 'x empty_list -| Set of ('x expr, comma) nsepseq braces -| EmptySet of 'x empty_set -| NoneExpr of 'x none_expr -| FunCall of 'x fun_call -| ConstrApp of 'x constr_app -| SomeApp of (c_Some * 'x arguments) reg -| MapLookUp of 'x map_lookup reg -| ParExpr of 'x 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 'x tuple = ('x expr, comma) nsepseq par +and 'a tuple = ('a expr, comma) nsepseq par -and 'x empty_list = - (lbracket * rbracket * colon * 'x type_expr) par +and 'a empty_list = + (lbracket * rbracket * colon * 'a type_expr) par -and 'x empty_set = - (lbrace * rbrace * colon * 'x type_expr) par +and 'a empty_set = + (lbrace * rbrace * colon * 'a type_expr) par -and 'x none_expr = - (c_None * colon * 'x type_expr) par +and 'a none_expr = + (c_None * colon * 'a type_expr) par -and 'x fun_call = ('x fun_name * 'x arguments) reg +and 'a fun_call = ('a fun_name * 'a arguments) reg -and 'x arguments = 'x tuple +and 'a arguments = 'a tuple -and 'x constr_app = ('x constr * 'x arguments) reg +and 'a constr_app = ('a constr * 'a arguments) reg -and 'x map_lookup = { - map_name : 'x variable; +and 'a map_lookup = { + map_name : 'a variable; selector : dot; - index : 'x expr brackets + index : 'a expr brackets } (* Patterns *) -and 'x pattern = ('x core_pattern, cons) nsepseq reg +and 'a pattern = ('a core_pattern, cons) nsepseq reg -and 'x core_pattern = +and 'a core_pattern = PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -421,13 +421,13 @@ and 'x core_pattern = | PFalse of c_False | PTrue of c_True | PNone of c_None -| PSome of (c_Some * 'x core_pattern par) reg -| PList of 'x list_pattern -| PTuple of ('x 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 'x list_pattern = - Sugar of ('x core_pattern, comma) sepseq brackets -| Raw of ('x core_pattern * cons * 'x 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 *) @@ -513,77 +513,77 @@ let local_decl_to_region = function (* Printing the tokens with their source regions *) -type 'x visitor = { - ass_instr : 'x ass_instr -> unit; - bind_to : (region * 'x variable) option -> unit; - block : 'x block reg -> unit; +type 'a visitor = { + ass_instr : 'a ass_instr -> unit; + bind_to : (region * 'a variable) option -> unit; + block : 'a block reg -> unit; bytes : (string * MBytes.t) reg -> unit; - cartesian : 'x cartesian -> unit; - case : 'x case -> unit; - cases : 'x cases -> unit; - conditional : 'x conditional -> unit; - const_decl : 'x const_decl reg -> unit; - constr : 'x constr -> unit; - constr_app : 'x constr_app -> unit; - core_pattern : 'x core_pattern -> 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 option -> unit; - empty_list : 'x empty_list -> unit; - empty_set : 'x empty_set -> unit; - expr : 'x expr -> unit; - fail : (kwd_fail * 'x expr) -> unit; - field_decl : 'x field_decl -> unit; - field_decls : 'x field_decls -> unit; - for_collect : 'x for_collect reg -> unit; - for_int : 'x for_int reg -> unit; - for_loop : 'x for_loop -> unit; - fun_call : 'x fun_call -> unit; - fun_decl : 'x fun_decl reg -> unit; - instruction : 'x instruction -> unit; - instructions : 'x instructions -> 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 : 'x lambda_decl -> unit; - list : ('x expr, region) nsepseq brackets -> unit; - list_pattern : 'x list_pattern -> unit; - loop : 'x loop -> unit; - map_lookup : 'x map_lookup reg -> unit; - match_instr : 'x match_instr -> unit; - none_expr : 'x none_expr -> 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; nsepseq : 'a.string -> ('a -> unit) -> ('a, region) nsepseq -> unit; - operations_decl : 'x operations_decl reg -> unit; - par_expr : 'x expr par -> unit; - par_type : 'x type_expr par -> unit; - param_decl : 'x param_decl -> unit; - parameter_decl : 'x parameter_decl reg -> unit; - parameters : 'x parameters -> unit; - param_const : 'x param_const -> unit; - param_var : 'x param_var -> unit; - pattern : 'x pattern -> unit; - patterns : 'x core_pattern par -> unit; - proc_decl : 'x proc_decl reg -> unit; - psome : (region * 'x core_pattern par) reg -> unit; - ptuple : ('x core_pattern, region) nsepseq par -> unit; - raw : ('x core_pattern * region * 'x pattern) par -> unit; - record_type : 'x record_type -> 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; sepseq : 'a.string -> ('a -> unit) -> ('a, region) sepseq -> unit; - set : ('x expr, region) nsepseq braces -> unit; - single_instr : 'x single_instr -> unit; - some_app : (region * 'x arguments) reg -> unit; - step : (region * 'x expr) option -> unit; - storage_decl : 'x storage_decl reg -> 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; string : string reg -> unit; - sugar : ('x core_pattern, region) sepseq brackets -> unit; - sum_type : ('x variant, region) nsepseq reg -> unit; + sugar : ('a core_pattern, region) sepseq brackets -> unit; + sum_type : ('a variant, region) nsepseq reg -> unit; terminator : semi option -> unit; token : region -> string -> unit; - tuple : 'x arguments -> unit; - type_app : ('x type_name * 'x type_tuple) reg -> unit; - type_decl : 'x type_decl reg -> unit; - type_expr : 'x type_expr -> unit; - type_tuple : 'x type_tuple -> unit; - local_decl : 'x local_decl -> unit; - local_decls : 'x local_decl list -> unit; - var : 'x variable -> unit; - var_decl : 'x var_decl reg -> unit; - variant : 'x variant -> unit; - while_loop : 'x while_loop -> 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 } diff --git a/AST.mli b/AST.mli index cb6fbcd2b..3505f44d2 100644 --- a/AST.mli +++ b/AST.mli @@ -97,12 +97,12 @@ type eof = Region.t (* Literals *) -type 'x variable = string reg -type 'x fun_name = string reg -type 'x type_name = string reg -type 'x field_name = string reg -type 'x map_name = string reg -type 'x 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 *) @@ -128,227 +128,227 @@ type 'a braces = (lbrace * 'a * rbrace) reg type t = < ty:unit > ast -and 'x ast = { - types : 'x type_decl reg list; - constants : 'x const_decl reg list; - parameter : 'x parameter_decl reg; - storage : 'x storage_decl reg; - operations : 'x operations_decl reg; - lambdas : 'x lambda_decl list; - block : 'x block reg; +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 'x parameter_decl = { +and 'a parameter_decl = { kwd_parameter : kwd_parameter; - name : 'x variable; + name : 'a variable; colon : colon; - param_type : 'x type_expr; + param_type : 'a type_expr; terminator : semi option } -and 'x storage_decl = { +and 'a storage_decl = { kwd_storage : kwd_storage; - store_type : 'x type_expr; + store_type : 'a type_expr; terminator : semi option } -and 'x operations_decl = { +and 'a operations_decl = { kwd_operations : kwd_operations; - op_type : 'x type_expr; + op_type : 'a type_expr; terminator : semi option } (* Type declarations *) -and 'x type_decl = { +and 'a type_decl = { kwd_type : kwd_type; - name : 'x type_name; + name : 'a type_name; kwd_is : kwd_is; - type_expr : 'x type_expr; + type_expr : 'a type_expr; terminator : semi option } -and 'x type_expr = - Prod of 'x cartesian -| Sum of ('x variant, vbar) nsepseq reg -| Record of 'x record_type -| TypeApp of ('x type_name * 'x type_tuple) reg -| ParType of 'x type_expr par -| TAlias of 'x 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 'x cartesian = ('x type_expr, times) nsepseq reg +and 'a cartesian = ('a type_expr, times) nsepseq reg -and 'x variant = ('x constr * kwd_of * 'x cartesian) reg +and 'a variant = ('a constr * kwd_of * 'a cartesian) reg -and 'x record_type = (kwd_record * 'x field_decls * kwd_end) reg +and 'a record_type = (kwd_record * 'a field_decls * kwd_end) reg -and 'x field_decls = ('x field_decl, semi) nsepseq +and 'a field_decls = ('a field_decl, semi) nsepseq -and 'x field_decl = ('x variable * colon * 'x type_expr) reg +and 'a field_decl = ('a variable * colon * 'a type_expr) reg -and 'x type_tuple = ('x type_name, comma) nsepseq par +and 'a type_tuple = ('a type_name, comma) nsepseq par (* Function and procedure declarations *) -and 'x lambda_decl = - FunDecl of 'x fun_decl reg -| ProcDecl of 'x proc_decl reg +and 'a lambda_decl = + FunDecl of 'a fun_decl reg +| ProcDecl of 'a proc_decl reg -and 'x fun_decl = { +and 'a fun_decl = { kwd_function : kwd_function; - name : 'x variable; - param : 'x parameters; + name : 'a variable; + param : 'a parameters; colon : colon; - ret_type : 'x type_expr; + ret_type : 'a type_expr; kwd_is : kwd_is; - local_decls : 'x local_decl list; - block : 'x block reg; + local_decls : 'a local_decl list; + block : 'a block reg; kwd_with : kwd_with; - return : 'x expr; + return : 'a expr; terminator : semi option } -and 'x proc_decl = { +and 'a proc_decl = { kwd_procedure : kwd_procedure; - name : 'x variable; - param : 'x parameters; + name : 'a variable; + param : 'a parameters; kwd_is : kwd_is; - local_decls : 'x local_decl list; - block : 'x block reg; + local_decls : 'a local_decl list; + block : 'a block reg; terminator : semi option } -and 'x parameters = ('x param_decl, semi) nsepseq par +and 'a parameters = ('a param_decl, semi) nsepseq par -and 'x param_decl = - ParamConst of 'x param_const -| ParamVar of 'x param_var +and 'a param_decl = + ParamConst of 'a param_const +| ParamVar of 'a param_var -and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg +and 'a param_const = (kwd_const * 'a variable * colon * 'a type_expr) reg -and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg +and 'a param_var = (kwd_var * 'a variable * colon * 'a type_expr) reg -and 'x block = { +and 'a block = { opening : kwd_begin; - instr : 'x instructions; + instr : 'a instructions; terminator : semi option; close : kwd_end } -and 'x local_decl = - LocalLam of 'x lambda_decl -| LocalConst of 'x const_decl reg -| LocalVar of 'x 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 'x const_decl = { +and 'a const_decl = { kwd_const : kwd_const; - name : 'x variable; + name : 'a variable; colon : colon; - vtype : 'x type_expr; + vtype : 'a type_expr; equal : equal; - init : 'x expr; + init : 'a expr; terminator : semi option } -and 'x var_decl = { +and 'a var_decl = { kwd_var : kwd_var; - name : 'x variable; + name : 'a variable; colon : colon; - vtype : 'x type_expr; + vtype : 'a type_expr; ass : ass; - init : 'x expr; + init : 'a expr; terminator : semi option } -and 'x instructions = ('x instruction, semi) nsepseq reg +and 'a instructions = ('a instruction, semi) nsepseq reg -and 'x instruction = - Single of 'x single_instr -| Block of 'x block reg +and 'a instruction = + Single of 'a single_instr +| Block of 'a block reg -and 'x single_instr = - Cond of 'x conditional reg -| Match of 'x match_instr reg -| Ass of 'x ass_instr -| Loop of 'x loop -| ProcCall of 'x 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 * 'x expr) reg +| Fail of (kwd_fail * 'a expr) reg -and 'x conditional = { +and 'a conditional = { kwd_if : kwd_if; - test : 'x expr; + test : 'a expr; kwd_then : kwd_then; - ifso : 'x instruction; + ifso : 'a instruction; kwd_else : kwd_else; - ifnot : 'x instruction + ifnot : 'a instruction } -and 'x match_instr = { +and 'a match_instr = { kwd_match : kwd_match; - expr : 'x expr; + expr : 'a expr; kwd_with : kwd_with; lead_vbar : vbar option; - cases : 'x cases; + cases : 'a cases; kwd_end : kwd_end } -and 'x cases = ('x case, vbar) nsepseq reg +and 'a cases = ('a case, vbar) nsepseq reg -and 'x case = ('x pattern * arrow * 'x instruction) reg +and 'a case = ('a pattern * arrow * 'a instruction) reg -and 'x ass_instr = ('x variable * ass * 'x expr) reg +and 'a ass_instr = ('a variable * ass * 'a expr) reg -and 'x loop = - While of 'x while_loop -| For of 'x for_loop +and 'a loop = + While of 'a while_loop +| For of 'a for_loop -and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg +and 'a while_loop = (kwd_while * 'a expr * 'a block reg) reg -and 'x for_loop = - ForInt of 'x for_int reg -| ForCollect of 'x for_collect reg +and 'a for_loop = + ForInt of 'a for_int reg +| ForCollect of 'a for_collect reg -and 'x for_int = { +and 'a for_int = { kwd_for : kwd_for; - ass : 'x ass_instr; + ass : 'a ass_instr; down : kwd_down option; kwd_to : kwd_to; - bound : 'x expr; - step : (kwd_step * 'x expr) option; - block : 'x block reg + bound : 'a expr; + step : (kwd_step * 'a expr) option; + block : 'a block reg } -and 'x for_collect = { +and 'a for_collect = { kwd_for : kwd_for; - var : 'x variable; - bind_to : (arrow * 'x variable) option; + var : 'a variable; + bind_to : (arrow * 'a variable) option; kwd_in : kwd_in; - expr : 'x expr; - block : 'x block reg + expr : 'a expr; + block : 'a block reg } (* Expressions *) -and 'x expr = - Or of ('x expr * bool_or * 'x expr) reg -| And of ('x expr * bool_and * 'x expr) reg -| Lt of ('x expr * lt * 'x expr) reg -| Leq of ('x expr * leq * 'x expr) reg -| Gt of ('x expr * gt * 'x expr) reg -| Geq of ('x expr * geq * 'x expr) reg -| Equal of ('x expr * equal * 'x expr) reg -| Neq of ('x expr * neq * 'x expr) reg -| Cat of ('x expr * cat * 'x expr) reg -| Cons of ('x expr * cons * 'x expr) reg -| Add of ('x expr * plus * 'x expr) reg -| Sub of ('x expr * minus * 'x expr) reg -| Mult of ('x expr * times * 'x expr) reg -| Div of ('x expr * slash * 'x expr) reg -| Mod of ('x expr * kwd_mod * 'x expr) reg -| Neg of (minus * 'x expr) reg -| Not of (kwd_not * 'x 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 'x expr = | False of c_False | True of c_True | Unit of c_Unit -| Tuple of 'x tuple -| List of ('x expr, comma) nsepseq brackets -| EmptyList of 'x empty_list -| Set of ('x expr, comma) nsepseq braces -| EmptySet of 'x empty_set -| NoneExpr of 'x none_expr -| FunCall of 'x fun_call -| ConstrApp of 'x constr_app -| SomeApp of (c_Some * 'x arguments) reg -| MapLookUp of 'x map_lookup reg -| ParExpr of 'x 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 'x tuple = ('x expr, comma) nsepseq par +and 'a tuple = ('a expr, comma) nsepseq par -and 'x empty_list = - (lbracket * rbracket * colon * 'x type_expr) par +and 'a empty_list = + (lbracket * rbracket * colon * 'a type_expr) par -and 'x empty_set = - (lbrace * rbrace * colon * 'x type_expr) par +and 'a empty_set = + (lbrace * rbrace * colon * 'a type_expr) par -and 'x none_expr = - (c_None * colon * 'x type_expr) par +and 'a none_expr = + (c_None * colon * 'a type_expr) par -and 'x fun_call = ('x fun_name * 'x arguments) reg +and 'a fun_call = ('a fun_name * 'a arguments) reg -and 'x arguments = 'x tuple +and 'a arguments = 'a tuple -and 'x constr_app = ('x constr * 'x arguments) reg +and 'a constr_app = ('a constr * 'a arguments) reg -and 'x map_lookup = { - map_name : 'x variable; +and 'a map_lookup = { + map_name : 'a variable; selector : dot; - index : 'x expr brackets + index : 'a expr brackets } (* Patterns *) -and 'x pattern = ('x core_pattern, cons) nsepseq reg +and 'a pattern = ('a core_pattern, cons) nsepseq reg -and 'x core_pattern = +and 'a core_pattern = PVar of Lexer.lexeme reg | PWild of wild | PInt of (Lexer.lexeme * Z.t) reg @@ -405,97 +405,97 @@ and 'x core_pattern = | PFalse of c_False | PTrue of c_True | PNone of c_None -| PSome of (c_Some * 'x core_pattern par) reg -| PList of 'x list_pattern -| PTuple of ('x 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 'x list_pattern = - Sugar of ('x core_pattern, comma) sepseq brackets -| Raw of ('x core_pattern * cons * 'x 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 : 'x type_expr -> Region.t +val type_expr_to_region : 'a type_expr -> Region.t -val expr_to_region : 'x expr -> Region.t +val expr_to_region : 'a expr -> Region.t -val instr_to_region : 'x instruction -> Region.t +val instr_to_region : 'a instruction -> Region.t -val core_pattern_to_region : 'x core_pattern -> Region.t +val core_pattern_to_region : 'a core_pattern -> Region.t -val local_decl_to_region : 'x local_decl -> Region.t +val local_decl_to_region : 'a local_decl -> Region.t -type 'x visitor = { - ass_instr : 'x ass_instr -> unit; - bind_to : (Region.t * 'x variable) option -> unit; - block : 'x block reg -> 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 : 'x cartesian -> unit; - case : 'x case -> unit; - cases : 'x cases -> unit; - conditional : 'x conditional -> unit; - const_decl : 'x const_decl reg -> unit; - constr : 'x constr -> unit; - constr_app : 'x constr_app -> unit; - core_pattern : 'x core_pattern -> 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 : 'x empty_list -> unit; - empty_set : 'x empty_set -> unit; - expr : 'x expr -> unit; - fail : (kwd_fail * 'x expr) -> unit; - field_decl : 'x field_decl -> unit; - field_decls : 'x field_decls -> unit; - for_collect : 'x for_collect reg -> unit; - for_int : 'x for_int reg -> unit; - for_loop : 'x for_loop -> unit; - fun_call : 'x fun_call -> unit; - fun_decl : 'x fun_decl reg -> unit; - instruction : 'x instruction -> unit; - instructions : 'x instructions -> 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 : 'x lambda_decl -> unit; - list : ('x expr, Region.t) nsepseq brackets -> unit; - list_pattern : 'x list_pattern -> unit; - loop : 'x loop -> unit; - map_lookup : 'x map_lookup reg -> unit; - match_instr : 'x match_instr -> unit; - none_expr : 'x none_expr -> unit; - nsepseq : 'x.string -> ('x -> unit) -> ('x, Region.t) nsepseq -> unit; - operations_decl : 'x operations_decl reg -> unit; - par_expr : 'x expr par -> unit; - par_type : 'x type_expr par -> unit; - param_decl : 'x param_decl -> unit; - parameter_decl : 'x parameter_decl reg -> unit; - parameters : 'x parameters -> unit; - param_const : 'x param_const -> unit; - param_var : 'x param_var -> unit; - pattern : 'x pattern -> unit; - patterns : 'x core_pattern par -> unit; - proc_decl : 'x proc_decl reg -> unit; - psome : (Region.t * 'x core_pattern par) reg -> unit; - ptuple : ('x core_pattern, Region.t) nsepseq par -> unit; - raw : ('x core_pattern * Region.t * 'x pattern) par -> unit; - record_type : 'x record_type -> unit; - sepseq : 'x.string -> ('x -> unit) -> ('x, Region.t) sepseq -> unit; - set : ('x expr, Region.t) nsepseq braces -> unit; - single_instr : 'x single_instr -> unit; - some_app : (Region.t * 'x arguments) reg -> unit; - step : (Region.t * 'x expr) option -> unit; - storage_decl : 'x storage_decl 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 : ('x core_pattern, Region.t) sepseq brackets -> unit; - sum_type : ('x variant, Region.t) nsepseq 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 : 'x arguments -> unit; - type_app : ('x type_name * 'x type_tuple) reg -> unit; - type_decl : 'x type_decl reg -> unit; - type_expr : 'x type_expr -> unit; - type_tuple : 'x type_tuple -> unit; - local_decl : 'x local_decl -> unit; - local_decls : 'x local_decl list -> unit; - var : 'x variable -> unit; - var_decl : 'x var_decl reg -> unit; - variant : 'x variant -> unit; - while_loop : 'x while_loop -> 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 } diff --git a/Print.ml b/Print.ml index c41da7f0a..50f5e19dc 100644 --- a/Print.ml +++ b/Print.ml @@ -47,7 +47,7 @@ and print_int _visitor {region; value = lexeme, abstract} = (* Main printing function *) -and print_tokens (v: 'x visitor) ast = +and print_tokens (v: 'a visitor) ast = List.iter v.type_decl ast.types; v.parameter_decl ast.parameter; v.storage_decl ast.storage; @@ -56,31 +56,31 @@ and print_tokens (v: 'x visitor) ast = v.block ast.block; v.token ast.eof "EOF" -and print_parameter_decl (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) = function +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 @@ -88,55 +88,55 @@ and print_type_expr (v: 'x visitor) = function | ParType par_type -> v.par_type par_type | TAlias type_alias -> v.var type_alias -and print_cartesian (v: 'x visitor) {value=sequence; _} = +and print_cartesian (v: 'a visitor) {value=sequence; _} = v.nsepseq "*" v.type_expr sequence -and print_variant (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=sequence; _} = +and print_sum_type (v: 'a visitor) {value=sequence; _} = v.nsepseq "|" v.variant sequence -and print_record_type (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) sequence = +and print_field_decls (v: 'a visitor) sequence = v.nsepseq ";" v.field_decl sequence -and print_field_decl (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) = function +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: 'x visitor) {value=node; _} = +and print_fun_decl (v: 'a visitor) {value=node; _} = v.token node.kwd_function "function"; v.var node.name; v.parameters node.param; @@ -149,7 +149,7 @@ and print_fun_decl (v: 'x visitor) {value=node; _} = v.expr node.return; v.terminator node.terminator -and print_proc_decl (v: 'x visitor) {value=node; _} = +and print_proc_decl (v: 'a visitor) {value=node; _} = v.token node.kwd_procedure "procedure"; v.var node.name; v.parameters node.param; @@ -158,45 +158,45 @@ and print_proc_decl (v: 'x visitor) {value=node; _} = v.block node.block; v.terminator node.terminator -and print_parameters (v: 'x visitor) {value=node; _} = +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: 'x visitor) = function +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) sequence = +and print_local_decls (v: 'a visitor) sequence = List.iter v.local_decl sequence -and print_local_decl (v: 'x visitor) = function +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: 'x visitor) {value=node; _} = +and print_const_decl (v: 'a visitor) {value=node; _} = v.token node.kwd_const "const"; v.var node.name; v.token node.colon ":"; @@ -205,7 +205,7 @@ and print_const_decl (v: 'x visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_var_decl (v: 'x visitor) {value=node; _} = +and print_var_decl (v: 'a visitor) {value=node; _} = v.token node.kwd_var "var"; v.var node.name; v.token node.colon ":"; @@ -214,14 +214,14 @@ and print_var_decl (v: 'x visitor) {value=node; _} = v.expr node.init; v.terminator node.terminator -and print_instructions (v: 'x visitor) {value=sequence; _} = +and print_instructions (v: 'a visitor) {value=sequence; _} = v.nsepseq ";" v.instruction sequence -and print_instruction (v: 'x visitor) = function +and print_instruction (v: 'a visitor) = function Single instr -> v.single_instr instr | Block block -> v.block block -and print_single_instr (v: 'x visitor) = function +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 @@ -230,11 +230,11 @@ and print_single_instr (v: 'x visitor) = function | Null kwd_null -> v.token kwd_null "null" | Fail {value; _} -> v.fail value -and print_fail (v: 'x visitor) (kwd_fail, expr) = +and print_fail (v: 'a visitor) (kwd_fail, expr) = v.token kwd_fail "fail"; v.expr expr -and print_conditional (v: 'x visitor) node = +and print_conditional (v: 'a visitor) node = v.token node.kwd_if "if"; v.expr node.test; v.token node.kwd_then "then"; @@ -242,43 +242,43 @@ and print_conditional (v: 'x visitor) node = v.token node.kwd_else "else"; v.instruction node.ifnot -and print_match_instr (v: 'x visitor) node = +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: 'x visitor) {value=sequence; _} = +and print_cases (v: 'a visitor) {value=sequence; _} = v.nsepseq "|" v.case sequence -and print_case (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) = function +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: 'x visitor) {value=node; _} = +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: 'x visitor) = function +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: 'x visitor) ({value=node; _} : 'x for_int reg) = +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; @@ -287,17 +287,17 @@ and print_for_int (v: 'x visitor) ({value=node; _} : 'x for_int reg) = v.step node.step; v.block node.block -and print_down (v: 'x visitor) = function +and print_down (v: 'a visitor) = function Some kwd_down -> v.token kwd_down "down" | None -> () -and print_step (v: 'x visitor) = function +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: 'x visitor) ({value=node; _} : 'x for_collect reg) = +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; @@ -305,13 +305,13 @@ and print_for_collect (v: 'x visitor) ({value=node; _} : 'x for_collect reg) = v.expr node.expr; v.block node.block -and print_bind_to (v: 'x visitor) = function +and print_bind_to (v: 'a visitor) = function Some (arrow, variable) -> v.token arrow "->"; v.var variable | None -> () -and print_expr (v: 'x visitor) = function +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; _} -> @@ -365,19 +365,19 @@ and print_expr (v: 'x visitor) = function | MapLookUp lookup -> v.map_lookup lookup | ParExpr pexpr -> v.par_expr pexpr -and print_tuple (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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 "["; @@ -386,13 +386,13 @@ and print_empty_list (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_set (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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 "{"; @@ -401,7 +401,7 @@ and print_empty_set (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_none_expr (v: 'x visitor) {value=node; _} = +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"; @@ -409,22 +409,22 @@ and print_none_expr (v: 'x visitor) {value=node; _} = v.type_expr type_expr; v.token rpar ")" -and print_fun_call (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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 "."; @@ -432,16 +432,16 @@ and print_map_lookup (v: 'x visitor) {value=node; _} = v.expr expr; v.token rbracket "]" -and print_par_expr (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=sequence; _} = +and print_pattern (v: 'a visitor) {value=sequence; _} = v.nsepseq "<:" v.core_pattern sequence -and print_core_pattern (v: 'x visitor) = function +and print_core_pattern (v: 'a visitor) = function PVar var -> v.var var | PWild wild -> v.token wild "_" | PInt i -> v.int i @@ -455,28 +455,28 @@ and print_core_pattern (v: 'x visitor) = function | PList pattern -> v.list_pattern pattern | PTuple ptuple -> v.ptuple ptuple -and print_psome (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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: 'x visitor) = function +and print_list_pattern (v: 'a visitor) = function Sugar sugar -> v.sugar sugar | Raw raw -> v.raw raw -and print_sugar (v: 'x visitor) {value=node; _} = +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: 'x visitor) {value=node; _} = +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; @@ -484,17 +484,17 @@ and print_raw (v: 'x visitor) {value=node; _} = v.pattern pattern; v.token rpar ")" -and print_ptuple (v: 'x visitor) {value=node; _} = +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: 'x visitor) = function +and print_terminator (v: 'a visitor) = function Some semi -> v.token semi ";" | None -> () -let rec visitor () : 'x visitor = { +let rec visitor () : 'a visitor = { nsepseq = print_nsepseq; sepseq = print_sepseq; token = print_token (visitor ()); From 00ff4bc32221cf3574ab8e06156072f1a2b30500 Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 21:00:48 +0100 Subject: [PATCH 8/8] Revert "Threaded 'a parameter everywhere" This reverts commit 40377a80dfab320bd2ef0af09e5d752350c9cb1d. --- AST.ml | 1108 +++++++++++++++++++++++++++++++++++++------------ AST.mli | 497 ++++++++++------------ ParserMain.ml | 2 +- Print.ml | 573 ------------------------- Print.mli | 5 - typecheck.ml | 116 +++--- 6 files changed, 1112 insertions(+), 1189 deletions(-) delete mode 100644 Print.ml delete mode 100644 Print.mli 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 - *)