From 40377a80dfab320bd2ef0af09e5d752350c9cb1d Mon Sep 17 00:00:00 2001 From: Your Name Date: Tue, 5 Mar 2019 18:13:09 +0100 Subject: [PATCH 01/14] 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 02/14] 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 03/14] =?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 04/14] 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 05/14] 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 06/14] =?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 07/14] 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 08/14] 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 - *) From 172986bc03973fd07fb91511444e7c88fe1118bb Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 00:07:57 +0100 Subject: [PATCH 09/14] weird bug --- AST2.ml | 547 ++++++++++++++++++++++++++++++++++++++++++++++++++ ParserMain.ml | 4 + typecheck.ml | 21 +- 3 files changed, 561 insertions(+), 11 deletions(-) create mode 100644 AST2.ml diff --git a/AST2.ml b/AST2.ml new file mode 100644 index 000000000..a4235e3c9 --- /dev/null +++ b/AST2.ml @@ -0,0 +1,547 @@ +[@@@warning "-30"] + +module I = AST + +open Region + +module SMap = Map.Make(String) + +module O = struct + type type_name = string + type ast = { + types : type_decl list; + parameter : typed_var; + storage : typed_var; + operations : typed_var; + declarations : decl list; + prev : I.ast; + } + and typed_var = { name:string; ty:type_expr } + and type_decl = { name:string; ty:type_expr } + and decl = { name:string; ty:type_expr; value: expr } + and type_expr = + Prod of type_expr list + | Sum of (type_name * type_expr) list + | Record of (type_name * type_expr) list + | TypeApp of type_name * type_expr list + | Function of { args: type_expr list; ret: type_expr } + | Ref of type_expr + | Unit + | Lambda of { + parameters: type_expr SMap.t; + declarations: decl list; + instructions: instr list; + body: expr; + } + | TODO + and expr = + Binary of { operator: string; left: expr; right: expr } + | Variable of string + | UnitExpr + and instr = + Fail +end + +(* open Sanity: *) +let (|>) v f = f v (* pipe f to v *) +let (@@) f v = f v (* apply f on v *) +let (@.) f g x = f (g x) (* compose *) +let map f l = List.rev (List.rev_map f l) +let fold_map f a l = + let f (acc, l) elem = + let acc', elem' = f acc elem + in acc', (elem' :: l) in + let last_acc, last_l = List.fold_left f (a, []) l + in last_acc, List.rev last_l + +(* Simplify the AST *) + +let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list = + fun (first, rest) -> first :: (map snd rest) + +let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list = + function + None -> [] + | Some nsepseq -> s_nsepseq nsepseq + +let s_name {value=name; region} : string = + let _ = region in + name + +let s_sum_type {value=sequence; region} : O.type_expr = + let _ = region in + let _todo = sequence in +(* Sum (List.map s_type_expr (s_nsepseq sequence)) *) + TODO + +and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = + let _ = kwd_record,region,kwd_end in + let _todo = (* s_field_decls *) field_decls in + TODO + +and s_type_app {value=node; region} : O.type_expr = + let _ = region in + let _todo = node in + TODO + (* let type_name, type_tuple = node in *) + (* s_var type_name; *) + (* s_type_tuple type_tuple *) + +and s_par_type {value=node; region} : O.type_expr = + let _ = region in + let _todo = node in + TODO + +and s_var {region; value=lexeme} : O.type_expr = + let _ = region in + let _todo = lexeme in + TODO + +(* let lpar, type_expr, rpar = node in + s_token lpar "("; + s_type_expr type_expr; + s_token rpar ")"*) + +(* I.{value=sequence; region} *) +(* (\* let _ = region in *\) *) +(* (\* Prod (List.map s_type_expr (s_nsepseq sequence)) *\) *) + +let s_cartesian _x = O.TODO +let s_sum_type _x = O.TODO +and s_record_type _x = O.TODO +and s_type_app _x = O.TODO +and s_par_type _x = O.TODO +and s_var _x = O.TODO + + +and s_type_expr : I.type_expr -> O.type_expr = function + Prod cartesian -> s_cartesian cartesian +| Sum sum_type -> s_sum_type sum_type +| Record record_type -> s_record_type record_type +| TypeApp type_app -> s_type_app type_app +| ParType par_type -> s_par_type par_type +| TAlias type_alias -> s_var type_alias + + +(* let s_ast (ast : I.ast) : O.ast = *) +(* let I.{types;constants;parameter;storage;operations;lambdas;block;eof} = ast in *) +(* let _ = eof in *) +(* O.{ *) +(* types = List.map s_type_decl types; *) +(* parameter = s_parameter parameter; *) +(* storage = s_storage storage; *) +(* operations = s_operations operations; *) +(* declarations = List.append (List.map s_const_decl constants) *) +(* (List.map s_lambda_decl lambdas) *) +(* [s_main_block block]; *) +(* prev = ast *) +(* } *) + +(* and s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = *) +(* let _ = kwd_type,kwd_is,terminator,region in *) +(* O.{ name = s_name name; ty = s_type_expr type_expr } *) + +(* and s_parameter_decl I.{value={kwd_parameter;name;colon;param_type;terminator};region} : O.typed_var = *) +(* let _ = region in *) +(* O.{ name = s_name name; ty = s_type_expr param_type } *) + +(* and s_storage_decl I.{value={kwd_storage; store_type; terminator}; region} : O.typed_var = *) +(* let _ = kwd_storage,terminator,region in *) +(* O.{ name = "storage"; ty = s_type_expr store_type } *) + +(* and s_operations_decl I.{value={kwd_operations;op_type;terminator}; region} : O.typed_var = *) +(* let _ = kwd_operations,terminator,region in *) +(* O.{ name = "operations"; ty = s_type_expr op_type } *) + +(* and s_const_decl I.{value={kwd_const;name;colon;vtype;equal;init;terminator}; region} : O.decl = *) +(* let _ = kwd_const,colon,equal,terminator in *) +(* O.{ name = s_name name; ty = s_type_expr vtype; value = s_expr init } *) + +(* and s_lambda_decl : I.lambda_decl -> O.decl = function *) +(* FunDecl fun_decl -> s_fun_decl fun_decl *) +(* | ProcDecl proc_decl -> s_proc_decl proc_decl *) + +(* and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = *) +(* let _ = kwd_function,colon,kwd_is,kwd_with,terminator in *) +(* O.{ *) +(* name = s_name name; *) +(* ty = Function { args = s_type_expr param; ret = s_type_expr ret_type }; *) +(* value = Lambda { *) +(* parameters = s_type_expr param; *) +(* declarations = List.map s_local_decls local_decls; *) +(* instructions = s_block block; *) +(* body = s_expr return *) +(* } *) +(* } *) + +(* and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} = *) +(* let _ = kwd_procedure,kwd_is,terminator in *) +(* O.{ *) +(* name = s_name name; *) +(* ty = Function { args = s_type_expr param; ret = Unit }; *) +(* value = Lambda { *) +(* parameters = s_type_expr param; *) +(* declarations = List.map s_local_decls local_decls; *) +(* instructions = s_block block; *) +(* body = O.UnitExpr *) +(* } *) +(* } *) + + + + + +(* let s_token region lexeme = *) +(* printf "%s: %s\n"(compact region) lexeme *) + +(* and s_var {region; value=lexeme} = *) +(* printf "%s: Ident \"%s\"\n" (compact region) lexeme *) + +(* and s_constr {region; value=lexeme} = *) +(* printf "%s: Constr \"%s\"\n" *) +(* (compact region) lexeme *) + +(* and s_string {region; value=lexeme} = *) +(* printf "%s: String \"%s\"\n" *) +(* (compact region) lexeme *) + +(* and s_bytes {region; value = lexeme, abstract} = *) +(* printf "%s: Bytes (\"%s\", \"0x%s\")\n" *) +(* (compact region) lexeme *) +(* (MBytes.to_hex abstract |> Hex.to_string) *) + +(* and s_int {region; value = lexeme, abstract} = *) +(* printf "%s: Int (\"%s\", %s)\n" *) +(* (compact region) lexeme *) +(* (Z.to_string abstract) *) + +(* and s_cartesian {value=sequence; _} = *) +(* s_nsepseq "*" s_type_expr sequence *) + +(* and s_variant {value=node; _} = *) +(* let constr, kwd_of, cartesian = node in *) +(* s_constr constr; *) +(* s_token kwd_of "of"; *) +(* s_cartesian cartesian *) + +(* and s_field_decls sequence = *) +(* s_nsepseq ";" s_field_decl sequence *) + +(* and s_field_decl {value=node; _} = *) +(* let var, colon, type_expr = node in *) +(* s_var var; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr *) + +(* and s_type_tuple {value=node; _} = *) +(* let lpar, sequence, rpar = node in *) +(* s_token lpar "("; *) +(* s_nsepseq "," s_var sequence; *) +(* s_token rpar ")" *) + + +(* and s_parameters {value=node; _} = *) +(* let lpar, sequence, rpar = node in *) +(* s_token lpar "("; *) +(* s_nsepseq ";" s_param_decl sequence; *) +(* s_token rpar ")" *) + +(* and s_param_decl = function *) +(* ParamConst param_const -> s_param_const param_const *) +(* | ParamVar param_var -> s_param_var param_var *) + +(* and s_param_const {value=node; _} = *) +(* let kwd_const, variable, colon, type_expr = node in *) +(* s_token kwd_const "const"; *) +(* s_var variable; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr *) + +(* and s_param_var {value=node; _} = *) +(* let kwd_var, variable, colon, type_expr = node in *) +(* s_token kwd_var "var"; *) +(* s_var variable; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr *) + +(* and s_block {value=node; _} = *) +(* s_token node.opening "begin"; *) +(* s_instructions node.instr; *) +(* s_terminator node.terminator; *) +(* s_token node.close "end" *) + +(* and s_local_decls sequence = *) +(* List.iter s_local_decl sequence *) + +(* and s_local_decl = function *) +(* LocalLam decl -> s_lambda_decl decl *) +(* | LocalConst decl -> s_const_decl decl *) +(* | LocalVar decl -> s_var_decl decl *) + +(* and s_var_decl {value={kwd_var;name;colon;vtype;ass;init;terminator}; region} = *) + + +(* and s_instructions {value=sequence; _} = *) +(* s_nsepseq ";" s_instruction sequence *) + +(* and s_instruction = function *) +(* Single instr -> s_single_instr instr *) +(* | Block block -> s_block block *) + +(* and s_single_instr = function *) +(* Cond {value; _} -> s_conditional value *) +(* | Match {value; _} -> s_match_instr value *) +(* | Ass instr -> s_ass_instr instr *) +(* | Loop loop -> s_loop loop *) +(* | ProcCall fun_call -> s_fun_call fun_call *) +(* | Null kwd_null -> s_token kwd_null "null" *) +(* | Fail {value; _} -> s_fail value *) + +(* and s_fail (kwd_fail, expr) = *) +(* s_token kwd_fail "fail"; *) +(* s_expr expr *) + +(* and s_conditional node ={kwd_if;test;kwd_then;ifso;kwd_else;ifnot} *) + + +(* and s_regionmatch_instr node ={kwd_match;expr;kwd_with;cases;kwd_end} *) + + +(* and s_region_cases {value=sequence; _} = *) +(* s_nsepseq "|" s_case sequence *) + +(* and s_case {value=node; _} = *) +(* let pattern, arrow, instruction = node in *) +(* s_pattern pattern; *) +(* s_token arrow "->"; *) +(* s_instruction instruction *) + +(* and s_ass_instr {value=node; _} = *) +(* let variable, ass, expr = node in *) +(* s_var variable; *) +(* s_token ass ":="; *) +(* s_expr expr *) + +(* and s_loop = function *) +(* While while_loop -> s_while_loop while_loop *) +(* | For for_loop -> s_for_loop for_loop *) + +(* and s_while_loop {value=node; _} = *) +(* let kwd_while, expr, block = node in *) +(* s_token kwd_while "while"; *) +(* s_expr expr; *) +(* s_block block *) + +(* and s_for_loop = function *) +(* ForInt for_int -> s_for_int for_int *) +(* | ForCollect for_collect -> s_for_collect for_collect *) + +(* and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : for_int reg) = *) + + +(* and s_down = function *) +(* Some kwd_down -> s_token kwd_down "down" *) +(* | None -> () *) + +(* and s_step = function *) +(* Some (kwd_step, expr) -> *) +(* s_token kwd_step "step"; *) +(* s_expr expr *) +(* | None -> () *) + +(* and s_for_collect ({value=node; _} : for_collect reg) = *) +(* s_token node.kwd_for "for"; *) +(* s_var node.var; *) +(* s_bind_to node.bind_to; *) +(* s_token node.kwd_in "in"; *) +(* s_expr node.expr; *) +(* s_block node.block *) + +(* and s_bind_to = function *) +(* Some (arrow, variable) -> *) +(* s_token arrow "->"; *) +(* s_var variable *) +(* | None -> () *) + +(* and s_expr = function *) +(* Or {value = expr1, bool_or, expr2; _} -> *) +(* s_expr expr1; s_token bool_or "||"; s_expr expr2 *) +(* | And {value = expr1, bool_and, expr2; _} -> *) +(* s_expr expr1; s_token bool_and "&&"; s_expr expr2 *) +(* | Lt {value = expr1, lt, expr2; _} -> *) +(* s_expr expr1; s_token lt "<"; s_expr expr2 *) +(* | Leq {value = expr1, leq, expr2; _} -> *) +(* s_expr expr1; s_token leq "<="; s_expr expr2 *) +(* | Gt {value = expr1, gt, expr2; _} -> *) +(* s_expr expr1; s_token gt ">"; s_expr expr2 *) +(* | Geq {value = expr1, geq, expr2; _} -> *) +(* s_expr expr1; s_token geq ">="; s_expr expr2 *) +(* | Equal {value = expr1, equal, expr2; _} -> *) +(* s_expr expr1; s_token equal "="; s_expr expr2 *) +(* | Neq {value = expr1, neq, expr2; _} -> *) +(* s_expr expr1; s_token neq "=/="; s_expr expr2 *) +(* | Cat {value = expr1, cat, expr2; _} -> *) +(* s_expr expr1; s_token cat "^"; s_expr expr2 *) +(* | Cons {value = expr1, cons, expr2; _} -> *) +(* s_expr expr1; s_token cons "<:"; s_expr expr2 *) +(* | Add {value = expr1, add, expr2; _} -> *) +(* s_expr expr1; s_token add "+"; s_expr expr2 *) +(* | Sub {value = expr1, sub, expr2; _} -> *) +(* s_expr expr1; s_token sub "-"; s_expr expr2 *) +(* | Mult {value = expr1, mult, expr2; _} -> *) +(* s_expr expr1; s_token mult "*"; s_expr expr2 *) +(* | Div {value = expr1, div, expr2; _} -> *) +(* s_expr expr1; s_token div "/"; s_expr expr2 *) +(* | Mod {value = expr1, kwd_mod, expr2; _} -> *) +(* s_expr expr1; s_token kwd_mod "mod"; s_expr expr2 *) +(* | Neg {value = minus, expr; _} -> *) +(* s_token minus "-"; s_expr expr *) +(* | Not {value = kwd_not, expr; _} -> *) +(* s_token kwd_not "not"; s_expr expr *) +(* | Int i -> s_int i *) +(* | Var var -> s_var var *) +(* | String s -> s_string s *) +(* | Bytes b -> s_bytes b *) +(* | False region -> s_token region "False" *) +(* | True region -> s_token region "True" *) +(* | Unit region -> s_token region "Unit" *) +(* | Tuple tuple -> s_tuple tuple *) +(* | List list -> s_list list *) +(* | EmptyList elist -> s_empty_list elist *) +(* | Set set -> s_set set *) +(* | EmptySet eset -> s_empty_set eset *) +(* | NoneExpr nexpr -> s_none_expr nexpr *) +(* | FunCall fun_call -> s_fun_call fun_call *) +(* | ConstrApp capp -> s_constr_app capp *) +(* | SomeApp sapp -> s_some_app sapp *) +(* | MapLookUp lookup -> s_map_lookup lookup *) +(* | ParExpr pexpr -> s_par_expr pexpr *) + +(* and s_tuple {value=node; _} = *) +(* let lpar, sequence, rpar = node in *) +(* s_token lpar "("; *) +(* s_nsepseq "," s_expr sequence; *) +(* s_token rpar ")" *) + +(* and s_list {value=node; _} = *) +(* let lbra, sequence, rbra = node in *) +(* s_token lbra "["; *) +(* s_nsepseq "," s_expr sequence; *) +(* s_token rbra "]" *) + +(* and s_empty_list {value=node; _} = *) +(* let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in *) +(* s_token lpar "("; *) +(* s_token lbracket "["; *) +(* s_token rbracket "]"; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr; *) +(* s_token rpar ")" *) + +(* and s_set {value=node; _} = *) +(* let lbrace, sequence, rbrace = node in *) +(* s_token lbrace "{"; *) +(* s_nsepseq "," s_expr sequence; *) +(* s_token rbrace "}" *) + +(* and s_empty_set {value=node; _} = *) +(* let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in *) +(* s_token lpar "("; *) +(* s_token lbrace "{"; *) +(* s_token rbrace "}"; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr; *) +(* s_token rpar ")" *) + +(* and s_none_expr {value=node; _} = *) +(* let lpar, (c_None, colon, type_expr), rpar = node in *) +(* s_token lpar "("; *) +(* s_token c_None "None"; *) +(* s_token colon ":"; *) +(* s_type_expr type_expr; *) +(* s_token rpar ")" *) + +(* and s_fun_call {value=node; _} = *) +(* let fun_name, arguments = node in *) +(* s_var fun_name; *) +(* s_tuple arguments *) + +(* and s_constr_app {value=node; _} = *) +(* let constr, arguments = node in *) +(* s_constr constr; *) +(* s_tuple arguments *) + +(* and s_some_app {value=node; _} = *) +(* let c_Some, arguments = node in *) +(* s_token c_Some "Some"; *) +(* s_tuple arguments *) + +(* and s_map_lookup {value=node; _} = *) +(* let {value = lbracket, expr, rbracket; _} = node.index in *) +(* s_var node.map_name; *) +(* s_token node.selector "."; *) +(* s_token lbracket "["; *) +(* s_expr expr; *) +(* s_token rbracket "]" *) + +(* and s_par_expr {value=node; _} = *) +(* let lpar, expr, rpar = node in *) +(* s_token lpar "("; *) +(* s_expr expr; *) +(* s_token rpar ")" *) + +(* and s_pattern {value=sequence; _} = *) +(* s_nsepseq "<:" s_core_pattern sequence *) + +(* and s_core_pattern = function *) +(* PVar var -> s_var var *) +(* | PWild wild -> s_token wild "_" *) +(* | PInt i -> s_int i *) +(* | PBytes b -> s_bytes b *) +(* | PString s -> s_string s *) +(* | PUnit region -> s_token region "Unit" *) +(* | PFalse region -> s_token region "False" *) +(* | PTrue region -> s_token region "True" *) +(* | PNone region -> s_token region "None" *) +(* | PSome psome -> s_psome psome *) +(* | PList pattern -> s_list_pattern pattern *) +(* | PTuple ptuple -> s_ptuple ptuple *) + +(* and s_psome {value=node; _} = *) +(* let c_Some, patterns = node in *) +(* s_token c_Some "Some"; *) +(* s_patterns patterns *) + +(* and s_patterns {value=node; _} = *) +(* let lpar, core_pattern, rpar = node in *) +(* s_token lpar "("; *) +(* s_core_pattern core_pattern; *) +(* s_token rpar ")" *) + +(* and s_list_pattern = function *) +(* Sugar sugar -> s_sugar sugar *) +(* | Raw raw -> s_raw raw *) + +(* and s_sugar {value=node; _} = *) +(* let lbracket, sequence, rbracket = node in *) +(* s_token lbracket "["; *) +(* s_sepseq "," s_core_pattern sequence; *) +(* s_token rbracket "]" *) + +(* and s_raw {value=node; _} = *) +(* let lpar, (core_pattern, cons, pattern), rpar = node in *) +(* s_token lpar "("; *) +(* s_core_pattern core_pattern; *) +(* s_token cons "<:"; *) +(* s_pattern pattern; *) +(* s_token rpar ")" *) + +(* and s_ptuple {value=node; _} = *) +(* let lpar, sequence, rpar = node in *) +(* s_token lpar "("; *) +(* s_nsepseq "," s_core_pattern sequence; *) +(* s_token rpar ")" *) + +(* and s_terminator = function *) +(* Some semi -> s_token semi ";" *) +(* | None -> () *) diff --git a/ParserMain.ml b/ParserMain.ml index 0081d3c87..682e0e274 100644 --- a/ParserMain.ml +++ b/ParserMain.ml @@ -69,3 +69,7 @@ let () = let () = close_all () in print_error ~offsets EvalOpt.mode error | Sys_error msg -> Utils.highlight msg + +let _ = + let open AST2 in + map diff --git a/typecheck.ml b/typecheck.ml index 99037d0bb..57339809d 100644 --- a/typecheck.ml +++ b/typecheck.ml @@ -1,3 +1,12 @@ +(* module I = AST (\* In *\) *) + +(* module SMap = Map.Make(String) *) + +(* type te = type_expr list SMap.t *) +(* type ve = type_expr list SMap.t *) +(* type tve = te * ve *) + +(* module I = AST (* In *) module SMap = Map.Make(String) @@ -86,17 +95,6 @@ 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 *) -let (@.) f g x = f (g x) (* compose *) -let map f l = List.rev (List.rev_map f l) -let fold_map f a l = - let f (acc, l) elem = - let acc', elem' = f acc elem - in acc', (elem' :: l) in - let last_acc, last_l = List.fold_left f (a, []) l - in last_acc, List.rev last_l let unreg : 'a reg -> 'a = fun {value; _} -> value let unpar : 'a par -> 'a = (fun (_left_par, x, _right_par) -> x) @. unreg @@ -228,3 +226,4 @@ let tc_ast (ast : I.ast) : O.ast = let _ve'' = ve'' in (* not needed anymore *) let _te'' = te'' in (* not needed anymore *) mk_ast ~lambdas ~block + *) From 20052c843adcb41f421ebb3856424c04dd8ab82c Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 10:02:47 +0100 Subject: [PATCH 10/14] Simplification of the AST. expr and pattern are not implemented yet. --- AST2.ml | 459 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 259 insertions(+), 200 deletions(-) diff --git a/AST2.ml b/AST2.ml index a4235e3c9..727136beb 100644 --- a/AST2.ml +++ b/AST2.ml @@ -1,5 +1,7 @@ [@@@warning "-30"] +exception TODO of string + module I = AST open Region @@ -8,6 +10,7 @@ module SMap = Map.Make(String) module O = struct type type_name = string + type var_name = string type ast = { types : type_decl list; parameter : typed_var; @@ -16,9 +19,9 @@ module O = struct declarations : decl list; prev : I.ast; } - and typed_var = { name:string; ty:type_expr } + and typed_var = { name:var_name; ty:type_expr } and type_decl = { name:string; ty:type_expr } - and decl = { name:string; ty:type_expr; value: expr } + and decl = { name:var_name; ty:type_expr; value: expr } and type_expr = Prod of type_expr list | Sum of (type_name * type_expr) list @@ -27,19 +30,44 @@ module O = struct | Function of { args: type_expr list; ret: type_expr } | Ref of type_expr | Unit + | Int + | TODO + and expr = + App of { operator: operator; arguments: expr list } + | Variable of var_name + | Constant of constant | Lambda of { parameters: type_expr SMap.t; declarations: decl list; instructions: instr list; - body: expr; + result: expr; } - | TODO - and expr = - Binary of { operator: string; left: expr; right: expr } - | Variable of string - | UnitExpr + and operator = Add | Sub | Lt | Gt | Function of string + and constant = + Unit + | Int of int and instr = - Fail + | Assignment of { name: var_name; value: expr } + | While of { condition: expr; body: instr list } + | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list } + | If of { condition: expr; ifso: instr list; ifnot: instr list } + | Match of { expr: expr; cases: (pattern * instr list) list } + | DropUnit of expr (* expr returns unit, drop the result. *) + | Fail of { expr: expr } + and pattern = + PVar of var_name + | PWild + | PInt of Z.t + | PBytes of MBytes.t + | PString of string + | PUnit + | PFalse + | PTrue + | PNone + | PSome of pattern + | Cons of pattern * pattern + | Null + | PTuple of pattern list end (* open Sanity: *) @@ -47,6 +75,11 @@ let (|>) v f = f v (* pipe f to v *) let (@@) f v = f v (* apply f on v *) let (@.) f g x = f (g x) (* compose *) let map f l = List.rev (List.rev_map f l) +(* TODO: check that List.to_seq, List.append and SMap.of_seq are not broken + (i.e. check that they are tail-recursive) *) +let append_map f l = map f l |> List.flatten +let append l1 l2 = List.append l1 l2 +let list_to_map l = l |> List.to_seq |> SMap.of_seq let fold_map f a l = let f (acc, l) elem = let acc', elem' = f acc elem @@ -64,23 +97,27 @@ let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list = None -> [] | Some nsepseq -> s_nsepseq nsepseq -let s_name {value=name; region} : string = - let _ = region in +let s_name {value=name; region} : O.var_name = + let () = ignore (region) in name -let s_sum_type {value=sequence; region} : O.type_expr = - let _ = region in +let rec s_cartesian {value=sequence; region} : O.type_expr = + let () = ignore (region) in + Prod (map s_type_expr (s_nsepseq sequence)) + +and s_sum_type {value=sequence; region} : O.type_expr = + let () = ignore (region) in let _todo = sequence in -(* Sum (List.map s_type_expr (s_nsepseq sequence)) *) +(* Sum (map s_type_expr (s_nsepseq sequence)) *) TODO and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = - let _ = kwd_record,region,kwd_end in + let () = ignore (kwd_record,region,kwd_end) in let _todo = (* s_field_decls *) field_decls in TODO and s_type_app {value=node; region} : O.type_expr = - let _ = region in + let () = ignore (region) in let _todo = node in TODO (* let type_name, type_tuple = node in *) @@ -88,12 +125,12 @@ and s_type_app {value=node; region} : O.type_expr = (* s_type_tuple type_tuple *) and s_par_type {value=node; region} : O.type_expr = - let _ = region in + let () = ignore (region) in let _todo = node in TODO and s_var {region; value=lexeme} : O.type_expr = - let _ = region in + let () = ignore (region) in let _todo = lexeme in TODO @@ -102,18 +139,6 @@ and s_var {region; value=lexeme} : O.type_expr = s_type_expr type_expr; s_token rpar ")"*) -(* I.{value=sequence; region} *) -(* (\* let _ = region in *\) *) -(* (\* Prod (List.map s_type_expr (s_nsepseq sequence)) *\) *) - -let s_cartesian _x = O.TODO -let s_sum_type _x = O.TODO -and s_record_type _x = O.TODO -and s_type_app _x = O.TODO -and s_par_type _x = O.TODO -and s_var _x = O.TODO - - and s_type_expr : I.type_expr -> O.type_expr = function Prod cartesian -> s_cartesian cartesian | Sum sum_type -> s_sum_type sum_type @@ -123,69 +148,218 @@ and s_type_expr : I.type_expr -> O.type_expr = function | TAlias type_alias -> s_var type_alias -(* let s_ast (ast : I.ast) : O.ast = *) -(* let I.{types;constants;parameter;storage;operations;lambdas;block;eof} = ast in *) -(* let _ = eof in *) -(* O.{ *) -(* types = List.map s_type_decl types; *) -(* parameter = s_parameter parameter; *) -(* storage = s_storage storage; *) -(* operations = s_operations operations; *) -(* declarations = List.append (List.map s_const_decl constants) *) -(* (List.map s_lambda_decl lambdas) *) -(* [s_main_block block]; *) -(* prev = ast *) -(* } *) +let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = + let () = ignore (kwd_type,kwd_is,terminator,region) in + O.{ name = s_name name; ty = s_type_expr type_expr } -(* and s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = *) -(* let _ = kwd_type,kwd_is,terminator,region in *) -(* O.{ name = s_name name; ty = s_type_expr type_expr } *) +let s_parameter_decl I.{value={kwd_parameter;name;colon;param_type;terminator};region} : O.typed_var = + let () = ignore (kwd_parameter,colon,terminator,region) in + O.{ name = s_name name; ty = s_type_expr param_type } -(* and s_parameter_decl I.{value={kwd_parameter;name;colon;param_type;terminator};region} : O.typed_var = *) -(* let _ = region in *) -(* O.{ name = s_name name; ty = s_type_expr param_type } *) +let s_storage_decl I.{value={kwd_storage; store_type; terminator}; region} : O.typed_var = + let () = ignore (kwd_storage,terminator,region) in + O.{ name = "storage"; ty = s_type_expr store_type } -(* and s_storage_decl I.{value={kwd_storage; store_type; terminator}; region} : O.typed_var = *) -(* let _ = kwd_storage,terminator,region in *) -(* O.{ name = "storage"; ty = s_type_expr store_type } *) +let s_operations_decl I.{value={kwd_operations;op_type;terminator}; region} : O.typed_var = + let () = ignore (kwd_operations,terminator,region) in + O.{ name = "operations"; ty = s_type_expr op_type } -(* and s_operations_decl I.{value={kwd_operations;op_type;terminator}; region} : O.typed_var = *) -(* let _ = kwd_operations,terminator,region in *) -(* O.{ name = "operations"; ty = s_type_expr op_type } *) +let s_expr : I.expr -> O.expr = function + | _ -> raise (TODO "simplify expressions") -(* and s_const_decl I.{value={kwd_const;name;colon;vtype;equal;init;terminator}; region} : O.decl = *) -(* let _ = kwd_const,colon,equal,terminator in *) -(* O.{ name = s_name name; ty = s_type_expr vtype; value = s_expr init } *) +let s_case : I.case -> O.pattern * (O.instr list) = function + | _ -> raise (TODO "simplify pattern matching cases") -(* and s_lambda_decl : I.lambda_decl -> O.decl = function *) -(* FunDecl fun_decl -> s_fun_decl fun_decl *) -(* | ProcDecl proc_decl -> s_proc_decl proc_decl *) +let s_const_decl I.{value={kwd_const;name;colon;vtype;equal;init;terminator}; region} : O.decl = + let () = ignore (kwd_const,colon,equal,terminator,region) in + O.{ name = s_name name; ty = s_type_expr vtype; value = s_expr init } -(* and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = *) -(* let _ = kwd_function,colon,kwd_is,kwd_with,terminator in *) -(* O.{ *) -(* name = s_name name; *) -(* ty = Function { args = s_type_expr param; ret = s_type_expr ret_type }; *) -(* value = Lambda { *) -(* parameters = s_type_expr param; *) -(* declarations = List.map s_local_decls local_decls; *) -(* instructions = s_block block; *) -(* body = s_expr return *) -(* } *) -(* } *) +let s_param_const {value=(kwd_const,variable,colon,type_expr); region} : string * O.type_expr = + let () = ignore (kwd_const,colon,region) in + s_name variable, s_type_expr type_expr -(* and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} = *) -(* let _ = kwd_procedure,kwd_is,terminator in *) -(* O.{ *) -(* name = s_name name; *) -(* ty = Function { args = s_type_expr param; ret = Unit }; *) -(* value = Lambda { *) -(* parameters = s_type_expr param; *) -(* declarations = List.map s_local_decls local_decls; *) -(* instructions = s_block block; *) -(* body = O.UnitExpr *) -(* } *) -(* } *) +let s_param_var {value=(kwd_var,variable,colon,type_expr); region} : string * O.type_expr = + let () = ignore (kwd_var,colon,region) in + s_name variable, s_type_expr type_expr + +let s_param_decl : I.param_decl -> string * O.type_expr = function + ParamConst p -> s_param_const p + | ParamVar p -> s_param_var p + +let s_parameters ({value=(lpar,param_decl,rpar);region} : I.parameters) : (string * O.type_expr) list = + let () = ignore (lpar,rpar,region) in + let l = (s_nsepseq param_decl) in + map s_param_decl l + +let rec s_var_decl I.{value={kwd_var;name;colon;vtype;ass;init;terminator}; region} : O.decl = + let () = ignore (kwd_var,colon,ass,terminator,region) in + O.{ + name = s_name name; + ty = s_type_expr vtype; + value = s_expr init + } + +and s_local_decl : I.local_decl -> O.decl = function + LocalLam decl -> s_lambda_decl decl +| LocalConst decl -> s_const_decl decl +| LocalVar decl -> s_var_decl decl + +and s_instructions ({value=sequence; region} : I.instructions) : O.instr list = + let () = ignore (region) in + append_map s_instruction (s_nsepseq sequence) + +and s_instruction : I.instruction -> O.instr list = function + Single instr -> s_single_instr instr +| Block block -> (s_block block) + +and s_conditional I.{kwd_if;test;kwd_then;ifso;kwd_else;ifnot} : O.instr = + let () = ignore (kwd_if,kwd_then,kwd_else) in + If { condition = s_expr test; ifso = s_instruction ifso; ifnot = s_instruction ifnot } + +and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr = + let {value=cases;region} = cases in + let () = ignore (kwd_match,kwd_with,lead_vbar,kwd_end,region) in + Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases) } + +and s_ass_instr {value=(variable,ass,expr); region} : O.instr = + let () = ignore (ass,region) in + Assignment { name = s_name variable; value = s_expr expr } + +and s_while_loop {value=(kwd_while, expr, block); region} : O.instr list = + let () = ignore (kwd_while,region) in + [While {condition = s_expr expr; body = s_block block}] + +and s_for_loop : I.for_loop -> O.instr list = function + ForInt for_int -> s_for_int for_int +| ForCollect for_collect -> s_for_collect for_collect + +and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.for_int reg) : O.instr list = + let {value=(variable,ass_kwd,expr);region = ass_region} = ass in + let () = ignore (kwd_for,ass_region,ass_kwd,kwd_to,region) in + let name = s_name variable in + let condition, operator = match down with Some kwd_down -> ignore kwd_down; O.Gt, O.Sub + | None -> O.Lt, O.Add in + let step = s_step step + in [ + Assignment { name; value = s_expr expr }; + (* TODO: lift the declaration of the variable *) + While { + condition = App { operator = condition; + arguments = [Variable name; s_expr bound] }; + body = append (s_block block) + [O.Assignment { name; + value = App { operator; + arguments = [Variable name; step]}}] + } + ] + +and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_collect reg) : O.instr list = + let () = ignore (kwd_for,kwd_in) in + [ + O.ForCollection { + list = s_expr expr; + key = s_name var; + value = s_bind_to bind_to; + body = s_block block + } + ] + +and s_step : (I.kwd_step * I.expr) option -> O.expr = function + Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr +| None -> Constant (Int 1) + +and s_bind_to : (I.arrow * I.variable) option -> O.var_name option = function + Some (arrow, variable) -> let () = ignore (arrow) in Some (s_name variable) + | None -> None + +and s_loop : I.loop -> O.instr list = function + While while_loop -> s_while_loop while_loop + | For for_loop -> s_for_loop for_loop + +and s_fun_call {value=(fun_name, arguments); region} : O.expr = + let () = ignore (region) in + App { operator = Function (s_name fun_name); arguments = s_arguments arguments } + +and s_arguments {value=(lpar, sequence, rpar); region} = + let () = ignore (lpar,rpar,region) in + map s_expr (s_nsepseq sequence); + +and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = + let () = ignore (kwd_fail) in + Fail { expr = s_expr expr } + + + + +and s_single_instr : I.single_instr -> O.instr list = function + Cond {value; _} -> [s_conditional value] +| Match {value; _} -> [s_match_instr value] +| Ass instr -> [s_ass_instr instr] +| Loop loop -> s_loop loop +| ProcCall fun_call -> [DropUnit (s_fun_call fun_call)] +| Null kwd_null -> let () = ignore (kwd_null) in + [] +| Fail {value; _} -> [s_fail value] + +and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list = + let () = ignore (opening,terminator,close) in + s_instructions instr + +and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_decls;block;kwd_with;return;terminator}; region} : O.decl = + let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in + O.{ + name = s_name name; + ty = Function { args = map snd (s_parameters param); ret = s_type_expr ret_type }; + value = Lambda { + parameters = s_parameters param |> list_to_map; + declarations = map s_local_decl local_decls; + instructions = s_block block; + result = s_expr return + } + } + +and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;terminator}; region} = + let () = ignore (kwd_procedure,kwd_is,terminator,region) in + O.{ + name = s_name name; + ty = Function { args = map snd (s_parameters param); ret = Unit }; + value = Lambda { + parameters = s_parameters param |> list_to_map; + declarations = map s_local_decl local_decls; + instructions = s_block block; + result = O.Constant O.Unit + } + } + +and s_lambda_decl : I.lambda_decl -> O.decl = function + FunDecl fun_decl -> s_fun_decl fun_decl +| ProcDecl proc_decl -> s_proc_decl proc_decl + +let s_main_block (block: I.block reg) : O.decl = + O.{ + name = "main"; + ty = Function { args = []; ret = Unit }; + value = Lambda { + parameters = SMap.empty; + declarations = []; + instructions = s_block block; + result = O.Constant O.Unit + } + } + +let s_ast (ast : I.ast) : O.ast = + let I.{types;constants;parameter;storage;operations;lambdas;block;eof} = ast in + let () = ignore (eof) in + O.{ + types = map s_type_decl types; + parameter = s_parameter_decl parameter; + storage = s_storage_decl storage; + operations = s_operations_decl operations; + declarations = List.flatten [(map s_const_decl constants); + (map s_lambda_decl lambdas); + [s_main_block block]]; + prev = ast + } @@ -250,63 +424,6 @@ and s_type_expr : I.type_expr -> O.type_expr = function (* ParamConst param_const -> s_param_const param_const *) (* | ParamVar param_var -> s_param_var param_var *) -(* and s_param_const {value=node; _} = *) -(* let kwd_const, variable, colon, type_expr = node in *) -(* s_token kwd_const "const"; *) -(* s_var variable; *) -(* s_token colon ":"; *) -(* s_type_expr type_expr *) - -(* and s_param_var {value=node; _} = *) -(* let kwd_var, variable, colon, type_expr = node in *) -(* s_token kwd_var "var"; *) -(* s_var variable; *) -(* s_token colon ":"; *) -(* s_type_expr type_expr *) - -(* and s_block {value=node; _} = *) -(* s_token node.opening "begin"; *) -(* s_instructions node.instr; *) -(* s_terminator node.terminator; *) -(* s_token node.close "end" *) - -(* and s_local_decls sequence = *) -(* List.iter s_local_decl sequence *) - -(* and s_local_decl = function *) -(* LocalLam decl -> s_lambda_decl decl *) -(* | LocalConst decl -> s_const_decl decl *) -(* | LocalVar decl -> s_var_decl decl *) - -(* and s_var_decl {value={kwd_var;name;colon;vtype;ass;init;terminator}; region} = *) - - -(* and s_instructions {value=sequence; _} = *) -(* s_nsepseq ";" s_instruction sequence *) - -(* and s_instruction = function *) -(* Single instr -> s_single_instr instr *) -(* | Block block -> s_block block *) - -(* and s_single_instr = function *) -(* Cond {value; _} -> s_conditional value *) -(* | Match {value; _} -> s_match_instr value *) -(* | Ass instr -> s_ass_instr instr *) -(* | Loop loop -> s_loop loop *) -(* | ProcCall fun_call -> s_fun_call fun_call *) -(* | Null kwd_null -> s_token kwd_null "null" *) -(* | Fail {value; _} -> s_fail value *) - -(* and s_fail (kwd_fail, expr) = *) -(* s_token kwd_fail "fail"; *) -(* s_expr expr *) - -(* and s_conditional node ={kwd_if;test;kwd_then;ifso;kwd_else;ifnot} *) - - -(* and s_regionmatch_instr node ={kwd_match;expr;kwd_with;cases;kwd_end} *) - - (* and s_region_cases {value=sequence; _} = *) (* s_nsepseq "|" s_case sequence *) @@ -316,53 +433,6 @@ and s_type_expr : I.type_expr -> O.type_expr = function (* s_token arrow "->"; *) (* s_instruction instruction *) -(* and s_ass_instr {value=node; _} = *) -(* let variable, ass, expr = node in *) -(* s_var variable; *) -(* s_token ass ":="; *) -(* s_expr expr *) - -(* and s_loop = function *) -(* While while_loop -> s_while_loop while_loop *) -(* | For for_loop -> s_for_loop for_loop *) - -(* and s_while_loop {value=node; _} = *) -(* let kwd_while, expr, block = node in *) -(* s_token kwd_while "while"; *) -(* s_expr expr; *) -(* s_block block *) - -(* and s_for_loop = function *) -(* ForInt for_int -> s_for_int for_int *) -(* | ForCollect for_collect -> s_for_collect for_collect *) - -(* and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : for_int reg) = *) - - -(* and s_down = function *) -(* Some kwd_down -> s_token kwd_down "down" *) -(* | None -> () *) - -(* and s_step = function *) -(* Some (kwd_step, expr) -> *) -(* s_token kwd_step "step"; *) -(* s_expr expr *) -(* | None -> () *) - -(* and s_for_collect ({value=node; _} : for_collect reg) = *) -(* s_token node.kwd_for "for"; *) -(* s_var node.var; *) -(* s_bind_to node.bind_to; *) -(* s_token node.kwd_in "in"; *) -(* s_expr node.expr; *) -(* s_block node.block *) - -(* and s_bind_to = function *) -(* Some (arrow, variable) -> *) -(* s_token arrow "->"; *) -(* s_var variable *) -(* | None -> () *) - (* and s_expr = function *) (* Or {value = expr1, bool_or, expr2; _} -> *) (* s_expr expr1; s_token bool_or "||"; s_expr expr2 *) @@ -417,12 +487,6 @@ and s_type_expr : I.type_expr -> O.type_expr = function (* | MapLookUp lookup -> s_map_lookup lookup *) (* | ParExpr pexpr -> s_par_expr pexpr *) -(* and s_tuple {value=node; _} = *) -(* let lpar, sequence, rpar = node in *) -(* s_token lpar "("; *) -(* s_nsepseq "," s_expr sequence; *) -(* s_token rpar ")" *) - (* and s_list {value=node; _} = *) (* let lbra, sequence, rbra = node in *) (* s_token lbra "["; *) @@ -461,11 +525,6 @@ and s_type_expr : I.type_expr -> O.type_expr = function (* s_type_expr type_expr; *) (* s_token rpar ")" *) -(* and s_fun_call {value=node; _} = *) -(* let fun_name, arguments = node in *) -(* s_var fun_name; *) -(* s_tuple arguments *) - (* and s_constr_app {value=node; _} = *) (* let constr, arguments = node in *) (* s_constr constr; *) From d89483f04dcff47f53fa140c5d7670fae00effd3 Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 10:13:20 +0100 Subject: [PATCH 11/14] First version of GitLab CI configuration --- .gitlab-ci.yml | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 .gitlab-ci.yml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml new file mode 100644 index 000000000..235d18158 --- /dev/null +++ b/.gitlab-ci.yml @@ -0,0 +1,12 @@ +before_script: + - apt-get update -qq + - apt-get -y -qq install libhidapi-dev libcap-dev + - wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux + - sudo mv opam-2.0.1-x86_64-linux /usr/local/bin/opam + +default-job: + script + - opam install --working-dir . + artifacts: + paths: + - parser.exe From ebf382093ec8344cc420ddb5a01ca03d561d16c8 Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 10:21:23 +0100 Subject: [PATCH 12/14] Typo in .gitlab-ci.yml --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 235d18158..212bb6ab7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,7 +5,7 @@ before_script: - sudo mv opam-2.0.1-x86_64-linux /usr/local/bin/opam default-job: - script + script: - opam install --working-dir . artifacts: paths: From 43ebc969ec93ee28f24e193a2ee2b57020bf79ef Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 10:26:16 +0100 Subject: [PATCH 13/14] GitLab does not have a sudo command --- .gitlab-ci.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 212bb6ab7..87856e8f7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,7 +2,9 @@ before_script: - apt-get update -qq - apt-get -y -qq install libhidapi-dev libcap-dev - wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux - - sudo mv opam-2.0.1-x86_64-linux /usr/local/bin/opam + - mkdir ~/opam-bin + - mv opam-2.0.1-x86_64-linux ~/opam-bin/opam + - export PATH="$HOME/opam-bin/opam${PATH:+:}${PATH:-}" default-job: script: From 6c3d6ceb180c91a96830b0146474b18c93d6bed9 Mon Sep 17 00:00:00 2001 From: Your Name Date: Wed, 6 Mar 2019 10:33:09 +0100 Subject: [PATCH 14/14] Added opam commands to .gitlab-ci.yml --- .gitlab-ci.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 87856e8f7..567f40355 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,6 +5,9 @@ before_script: - mkdir ~/opam-bin - mv opam-2.0.1-x86_64-linux ~/opam-bin/opam - export PATH="$HOME/opam-bin/opam${PATH:+:}${PATH:-}" + - opam init + - opam repository add jgb https://gitlab.com/gabriel.alfour/tezos-opam-repository.git + - eval $(opam env) default-job: script: