balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Revert "WIP…"

Browse Source 
This reverts commit 9b9760f052.
This commit is contained in:
Your Name 2019-03-05 21:00:47 +01:00
parent a6585b6e91
commit 78629b6652
9 changed files with 109 additions and 688 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

167
AST.ml
View File

@ -142,45 +142,9 @@ type 'a braces = (lbrace * 'a * rbrace) reg
(* The Abstract Syntax Tree *) (* The Abstract Syntax Tree *)
type ttrue = TTrue type t = < ty: unit > ast
type tfalse = TFalse
type ('a, 'type_expr_typecheck) gadt_if =
Present : 'a -> ('a, ttrue) gadt_if
(* It is possible to further ensure well-typedness at the meta level and 'x ast = {
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; types : 'x type_decl reg list;
constants : 'x const_decl reg list; constants : 'x const_decl reg list;
parameter : 'x parameter_decl reg; parameter : 'x parameter_decl reg;
@ -190,7 +154,6 @@ type 'x ast = {
block : 'x block reg; block : 'x block reg;
eof : eof eof : eof
} }
constraint 'x = 'x x_sig
and 'x parameter_decl = { and 'x parameter_decl = {
kwd_parameter : kwd_parameter; kwd_parameter : kwd_parameter;
@ -199,21 +162,18 @@ and 'x parameter_decl = {
param_type : 'x type_expr; param_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x storage_decl = { and 'x storage_decl = {
kwd_storage : kwd_storage; kwd_storage : kwd_storage;
store_type : 'x type_expr; store_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x operations_decl = { and 'x operations_decl = {
kwd_operations : kwd_operations; kwd_operations : kwd_operations;
op_type : 'x type_expr; op_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
(* Type declarations *) (* Type declarations *)
@ -224,79 +184,32 @@ and 'x type_decl = {
type_expr : 'x type_expr; type_expr : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x type_expr = and 'x type_expr =
Prod of ('x cartesian, ttrue) gadt_if Prod of 'x cartesian
| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if | Sum of ('x variant, vbar) nsepseq reg
| Record of ('x record_type, ttrue) gadt_if | Record of 'x record_type
| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if | TypeApp of ('x type_name * 'x type_tuple) reg
| ParType of ('x type_expr par, ttrue) gadt_if | ParType of 'x type_expr par
| TAlias of ('x variable, ttrue) gadt_if | TAlias of 'x variable
| 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 and 'x cartesian = ('x type_expr, times) nsepseq reg
constraint 'x = 'x x_sig
and 'x variant = ('x constr * kwd_of * 'x cartesian) reg 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 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 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 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 and 'x type_tuple = ('x type_name, comma) nsepseq par
constraint 'x = 'x x_sig
(* Function and procedure declarations *) (* Function and procedure declarations *)
and 'x lambda_decl = and 'x lambda_decl =
FunDecl of 'x fun_decl reg FunDecl of 'x fun_decl reg
| ProcDecl of 'x proc_decl reg | ProcDecl of 'x proc_decl reg
constraint 'x = 'x x_sig
and 'x fun_decl = { and 'x fun_decl = {
kwd_function : kwd_function; kwd_function : kwd_function;
@ -311,7 +224,6 @@ and 'x fun_decl = {
return : 'x expr; return : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x proc_decl = { and 'x proc_decl = {
kwd_procedure : kwd_procedure; kwd_procedure : kwd_procedure;
@ -322,21 +234,16 @@ and 'x proc_decl = {
block : 'x block reg; block : 'x block reg;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x parameters = ('x param_decl, semi) nsepseq par and 'x parameters = ('x param_decl, semi) nsepseq par
constraint 'x = 'x x_sig
and 'x param_decl = and 'x param_decl =
ParamConst of 'x param_const ParamConst of 'x param_const
| ParamVar of 'x param_var | ParamVar of 'x param_var
constraint 'x = 'x x_sig
and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg 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 and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg
constraint 'x = 'x x_sig
and 'x block = { and 'x block = {
opening : kwd_begin; opening : kwd_begin;
@ -344,13 +251,11 @@ and 'x block = {
terminator : semi option; terminator : semi option;
close : kwd_end close : kwd_end
} }
constraint 'x = 'x x_sig
and 'x local_decl = and 'x local_decl =
LocalLam of 'x lambda_decl LocalLam of 'x lambda_decl
| LocalConst of 'x const_decl reg | LocalConst of 'x const_decl reg
| LocalVar of 'x var_decl reg | LocalVar of 'x var_decl reg
constraint 'x = 'x x_sig
and 'x const_decl = { and 'x const_decl = {
kwd_const : kwd_const; kwd_const : kwd_const;
@ -361,7 +266,6 @@ and 'x const_decl = {
init : 'x expr; init : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x var_decl = { and 'x var_decl = {
kwd_var : kwd_var; kwd_var : kwd_var;
@ -372,15 +276,12 @@ and 'x var_decl = {
init : 'x expr; init : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x instructions = ('x instruction, semi) nsepseq reg and 'x instructions = ('x instruction, semi) nsepseq reg
constraint 'x = 'x x_sig
and 'x instruction = and 'x instruction =
Single of 'x single_instr Single of 'x single_instr
| Block of 'x block reg | Block of 'x block reg
constraint 'x = 'x x_sig
and 'x single_instr = and 'x single_instr =
Cond of 'x conditional reg Cond of 'x conditional reg
@ -390,7 +291,6 @@ and 'x single_instr =
| ProcCall of 'x fun_call | ProcCall of 'x fun_call
| Null of kwd_null | Null of kwd_null
| Fail of (kwd_fail * 'x expr) reg | Fail of (kwd_fail * 'x expr) reg
constraint 'x = 'x x_sig
and 'x conditional = { and 'x conditional = {
kwd_if : kwd_if; kwd_if : kwd_if;
@ -400,7 +300,6 @@ and 'x conditional = {
kwd_else : kwd_else; kwd_else : kwd_else;
ifnot : 'x instruction ifnot : 'x instruction
} }
constraint 'x = 'x x_sig
and 'x match_instr = { and 'x match_instr = {
kwd_match : kwd_match; kwd_match : kwd_match;
@ -410,29 +309,22 @@ and 'x match_instr = {
cases : 'x cases; cases : 'x cases;
kwd_end : kwd_end kwd_end : kwd_end
} }
constraint 'x = 'x x_sig
and 'x cases = ('x case, vbar) nsepseq reg and 'x cases = ('x case, vbar) nsepseq reg
constraint 'x = 'x x_sig
and 'x case = ('x pattern * arrow * 'x instruction) reg and 'x case = ('x pattern * arrow * 'x instruction) reg
constraint 'x = 'x x_sig
and 'x ass_instr = ('x variable * ass * 'x expr) reg and 'x ass_instr = ('x variable * ass * 'x expr) reg
constraint 'x = 'x x_sig
and 'x loop = and 'x loop =
While of 'x while_loop While of 'x while_loop
| For of 'x for_loop | For of 'x for_loop
constraint 'x = 'x x_sig
and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg
constraint 'x = 'x x_sig
and 'x for_loop = and 'x for_loop =
ForInt of 'x for_int reg ForInt of 'x for_int reg
| ForCollect of 'x for_collect reg | ForCollect of 'x for_collect reg
constraint 'x = 'x x_sig
and 'x for_int = { and 'x for_int = {
kwd_for : kwd_for; kwd_for : kwd_for;
@ -443,7 +335,6 @@ and 'x for_int = {
step : (kwd_step * 'x expr) option; step : (kwd_step * 'x expr) option;
block : 'x block reg block : 'x block reg
} }
constraint 'x = 'x x_sig
and 'x for_collect = { and 'x for_collect = {
kwd_for : kwd_for; kwd_for : kwd_for;
@ -453,7 +344,6 @@ and 'x for_collect = {
expr : 'x expr; expr : 'x expr;
block : 'x block reg block : 'x block reg
} }
constraint 'x = 'x x_sig
(* Expressions *) (* Expressions *)
@ -493,43 +383,33 @@ and 'x expr =
| SomeApp of (c_Some * 'x arguments) reg | SomeApp of (c_Some * 'x arguments) reg
| MapLookUp of 'x map_lookup reg | MapLookUp of 'x map_lookup reg
| ParExpr of 'x expr par | ParExpr of 'x expr par
constraint 'x = 'x x_sig
and 'x tuple = ('x expr, comma) nsepseq par and 'x tuple = ('x expr, comma) nsepseq par
constraint 'x = 'x x_sig
and 'x empty_list = and 'x empty_list =
(lbracket * rbracket * colon * 'x type_expr) par (lbracket * rbracket * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x empty_set = and 'x empty_set =
(lbrace * rbrace * colon * 'x type_expr) par (lbrace * rbrace * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x none_expr = and 'x none_expr =
(c_None * colon * 'x type_expr) par (c_None * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x fun_call = ('x fun_name * 'x arguments) reg and 'x fun_call = ('x fun_name * 'x arguments) reg
constraint 'x = 'x x_sig
and 'x arguments = 'x tuple and 'x arguments = 'x tuple
constraint 'x = 'x x_sig
and 'x constr_app = ('x constr * 'x arguments) reg and 'x constr_app = ('x constr * 'x arguments) reg
constraint 'x = 'x x_sig
and 'x map_lookup = { and 'x map_lookup = {
map_name : 'x variable; map_name : 'x variable;
selector : dot; selector : dot;
index : 'x expr brackets index : 'x expr brackets
} }
constraint 'x = 'x x_sig
(* Patterns *) (* Patterns *)
and 'x pattern = ('x core_pattern, cons) nsepseq reg and 'x pattern = ('x core_pattern, cons) nsepseq reg
constraint 'x = 'x x_sig
and 'x core_pattern = and 'x core_pattern =
PVar of Lexer.lexeme reg PVar of Lexer.lexeme reg
@ -544,39 +424,22 @@ and 'x core_pattern =
| PSome of (c_Some * 'x core_pattern par) reg | PSome of (c_Some * 'x core_pattern par) reg
| PList of 'x list_pattern | PList of 'x list_pattern
| PTuple of ('x core_pattern, comma) nsepseq par | PTuple of ('x core_pattern, comma) nsepseq par
constraint 'x = 'x x_sig
and 'x list_pattern = and 'x list_pattern =
Sugar of ('x core_pattern, comma) sepseq brackets Sugar of ('x core_pattern, comma) sepseq brackets
| Raw of ('x core_pattern * cons * 'x pattern) par | 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 *) (* Projecting regions *)
open! Region open! Region
let type_expr_to_region : parse_phase type_expr -> region = function let type_expr_to_region = function
Prod (Present node) -> node.region Prod node -> node.region
| Sum (Present node) -> node.region | Sum node -> node.region
| Record (Present node) -> node.region | Record node -> node.region
| TypeApp (Present node) -> node.region | TypeApp node -> node.region
| ParType (Present node) -> node.region | ParType node -> node.region
| TAlias (Present node) -> node.region | TAlias node -> node.region
| _ -> .
let expr_to_region = function let expr_to_region = function
Or {region; _} Or {region; _}

122
AST.mli
View File

@ -126,45 +126,9 @@ type 'a braces = (lbrace * 'a * rbrace) reg
(* The Abstract Syntax Tree *) (* The Abstract Syntax Tree *)
type ttrue = TTrue type t = < ty:unit > ast
type tfalse = TFalse
type ('a, 'type_expr_typecheck) gadt_if =
Present : 'a -> ('a, ttrue) gadt_if
(* It is possible to further ensure well-typedness at the meta level and 'x ast = {
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; types : 'x type_decl reg list;
constants : 'x const_decl reg list; constants : 'x const_decl reg list;
parameter : 'x parameter_decl reg; parameter : 'x parameter_decl reg;
@ -174,7 +138,6 @@ type 'x ast = {
block : 'x block reg; block : 'x block reg;
eof : eof eof : eof
} }
constraint 'x = 'x x_sig
and 'x parameter_decl = { and 'x parameter_decl = {
kwd_parameter : kwd_parameter; kwd_parameter : kwd_parameter;
@ -183,21 +146,18 @@ and 'x parameter_decl = {
param_type : 'x type_expr; param_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x storage_decl = { and 'x storage_decl = {
kwd_storage : kwd_storage; kwd_storage : kwd_storage;
store_type : 'x type_expr; store_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x operations_decl = { and 'x operations_decl = {
kwd_operations : kwd_operations; kwd_operations : kwd_operations;
op_type : 'x type_expr; op_type : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
(* Type declarations *) (* Type declarations *)
@ -208,47 +168,32 @@ and 'x type_decl = {
type_expr : 'x type_expr; type_expr : 'x type_expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x type_expr = and 'x type_expr =
Prod of ('x cartesian, ttrue) gadt_if Prod of 'x cartesian
| Sum of (('x variant, vbar) nsepseq reg, ttrue) gadt_if | Sum of ('x variant, vbar) nsepseq reg
| Record of ('x record_type, ttrue) gadt_if | Record of 'x record_type
| TypeApp of (('x type_name * 'x type_tuple) reg, ttrue) gadt_if | TypeApp of ('x type_name * 'x type_tuple) reg
| ParType of ('x type_expr par, ttrue) gadt_if | ParType of 'x type_expr par
| TAlias of ('x variable, ttrue) gadt_if | TAlias of 'x variable
| 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 and 'x cartesian = ('x type_expr, times) nsepseq reg
constraint 'x = 'x x_sig
and 'x variant = ('x constr * kwd_of * 'x cartesian) reg 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 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 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 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 and 'x type_tuple = ('x type_name, comma) nsepseq par
constraint 'x = 'x x_sig
(* Function and procedure declarations *) (* Function and procedure declarations *)
and 'x lambda_decl = and 'x lambda_decl =
FunDecl of 'x fun_decl reg FunDecl of 'x fun_decl reg
| ProcDecl of 'x proc_decl reg | ProcDecl of 'x proc_decl reg
constraint 'x = 'x x_sig
and 'x fun_decl = { and 'x fun_decl = {
kwd_function : kwd_function; kwd_function : kwd_function;
@ -263,7 +208,6 @@ and 'x fun_decl = {
return : 'x expr; return : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x proc_decl = { and 'x proc_decl = {
kwd_procedure : kwd_procedure; kwd_procedure : kwd_procedure;
@ -274,21 +218,16 @@ and 'x proc_decl = {
block : 'x block reg; block : 'x block reg;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x parameters = ('x param_decl, semi) nsepseq par and 'x parameters = ('x param_decl, semi) nsepseq par
constraint 'x = 'x x_sig
and 'x param_decl = and 'x param_decl =
ParamConst of 'x param_const ParamConst of 'x param_const
| ParamVar of 'x param_var | ParamVar of 'x param_var
constraint 'x = 'x x_sig
and 'x param_const = (kwd_const * 'x variable * colon * 'x type_expr) reg 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 and 'x param_var = (kwd_var * 'x variable * colon * 'x type_expr) reg
constraint 'x = 'x x_sig
and 'x block = { and 'x block = {
opening : kwd_begin; opening : kwd_begin;
@ -296,13 +235,11 @@ and 'x block = {
terminator : semi option; terminator : semi option;
close : kwd_end close : kwd_end
} }
constraint 'x = 'x x_sig
and 'x local_decl = and 'x local_decl =
LocalLam of 'x lambda_decl LocalLam of 'x lambda_decl
| LocalConst of 'x const_decl reg | LocalConst of 'x const_decl reg
| LocalVar of 'x var_decl reg | LocalVar of 'x var_decl reg
constraint 'x = 'x x_sig
and 'x const_decl = { and 'x const_decl = {
kwd_const : kwd_const; kwd_const : kwd_const;
@ -313,7 +250,6 @@ and 'x const_decl = {
init : 'x expr; init : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x var_decl = { and 'x var_decl = {
kwd_var : kwd_var; kwd_var : kwd_var;
@ -324,15 +260,12 @@ and 'x var_decl = {
init : 'x expr; init : 'x expr;
terminator : semi option terminator : semi option
} }
constraint 'x = 'x x_sig
and 'x instructions = ('x instruction, semi) nsepseq reg and 'x instructions = ('x instruction, semi) nsepseq reg
constraint 'x = 'x x_sig
and 'x instruction = and 'x instruction =
Single of 'x single_instr Single of 'x single_instr
| Block of 'x block reg | Block of 'x block reg
constraint 'x = 'x x_sig
and 'x single_instr = and 'x single_instr =
Cond of 'x conditional reg Cond of 'x conditional reg
@ -342,7 +275,6 @@ and 'x single_instr =
| ProcCall of 'x fun_call | ProcCall of 'x fun_call
| Null of kwd_null | Null of kwd_null
| Fail of (kwd_fail * 'x expr) reg | Fail of (kwd_fail * 'x expr) reg
constraint 'x = 'x x_sig
and 'x conditional = { and 'x conditional = {
kwd_if : kwd_if; kwd_if : kwd_if;
@ -352,7 +284,6 @@ and 'x conditional = {
kwd_else : kwd_else; kwd_else : kwd_else;
ifnot : 'x instruction ifnot : 'x instruction
} }
constraint 'x = 'x x_sig
and 'x match_instr = { and 'x match_instr = {
kwd_match : kwd_match; kwd_match : kwd_match;
@ -362,29 +293,22 @@ and 'x match_instr = {
cases : 'x cases; cases : 'x cases;
kwd_end : kwd_end kwd_end : kwd_end
} }
constraint 'x = 'x x_sig
and 'x cases = ('x case, vbar) nsepseq reg and 'x cases = ('x case, vbar) nsepseq reg
constraint 'x = 'x x_sig
and 'x case = ('x pattern * arrow * 'x instruction) reg and 'x case = ('x pattern * arrow * 'x instruction) reg
constraint 'x = 'x x_sig
and 'x ass_instr = ('x variable * ass * 'x expr) reg and 'x ass_instr = ('x variable * ass * 'x expr) reg
constraint 'x = 'x x_sig
and 'x loop = and 'x loop =
While of 'x while_loop While of 'x while_loop
| For of 'x for_loop | For of 'x for_loop
constraint 'x = 'x x_sig
and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg and 'x while_loop = (kwd_while * 'x expr * 'x block reg) reg
constraint 'x = 'x x_sig
and 'x for_loop = and 'x for_loop =
ForInt of 'x for_int reg ForInt of 'x for_int reg
| ForCollect of 'x for_collect reg | ForCollect of 'x for_collect reg
constraint 'x = 'x x_sig
and 'x for_int = { and 'x for_int = {
kwd_for : kwd_for; kwd_for : kwd_for;
@ -395,7 +319,6 @@ and 'x for_int = {
step : (kwd_step * 'x expr) option; step : (kwd_step * 'x expr) option;
block : 'x block reg block : 'x block reg
} }
constraint 'x = 'x x_sig
and 'x for_collect = { and 'x for_collect = {
kwd_for : kwd_for; kwd_for : kwd_for;
@ -405,7 +328,6 @@ and 'x for_collect = {
expr : 'x expr; expr : 'x expr;
block : 'x block reg block : 'x block reg
} }
constraint 'x = 'x x_sig
(* Expressions *) (* Expressions *)
@ -445,43 +367,33 @@ and 'x expr =
| SomeApp of (c_Some * 'x arguments) reg | SomeApp of (c_Some * 'x arguments) reg
| MapLookUp of 'x map_lookup reg | MapLookUp of 'x map_lookup reg
| ParExpr of 'x expr par | ParExpr of 'x expr par
constraint 'x = 'x x_sig
and 'x tuple = ('x expr, comma) nsepseq par and 'x tuple = ('x expr, comma) nsepseq par
constraint 'x = 'x x_sig
and 'x empty_list = and 'x empty_list =
(lbracket * rbracket * colon * 'x type_expr) par (lbracket * rbracket * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x empty_set = and 'x empty_set =
(lbrace * rbrace * colon * 'x type_expr) par (lbrace * rbrace * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x none_expr = and 'x none_expr =
(c_None * colon * 'x type_expr) par (c_None * colon * 'x type_expr) par
constraint 'x = 'x x_sig
and 'x fun_call = ('x fun_name * 'x arguments) reg and 'x fun_call = ('x fun_name * 'x arguments) reg
constraint 'x = 'x x_sig
and 'x arguments = 'x tuple and 'x arguments = 'x tuple
constraint 'x = 'x x_sig
and 'x constr_app = ('x constr * 'x arguments) reg and 'x constr_app = ('x constr * 'x arguments) reg
constraint 'x = 'x x_sig
and 'x map_lookup = { and 'x map_lookup = {
map_name : 'x variable; map_name : 'x variable;
selector : dot; selector : dot;
index : 'x expr brackets index : 'x expr brackets
} }
constraint 'x = 'x x_sig
(* Patterns *) (* Patterns *)
and 'x pattern = ('x core_pattern, cons) nsepseq reg and 'x pattern = ('x core_pattern, cons) nsepseq reg
constraint 'x = 'x x_sig
and 'x core_pattern = and 'x core_pattern =
PVar of Lexer.lexeme reg PVar of Lexer.lexeme reg
@ -496,30 +408,14 @@ and 'x core_pattern =
| PSome of (c_Some * 'x core_pattern par) reg | PSome of (c_Some * 'x core_pattern par) reg
| PList of 'x list_pattern | PList of 'x list_pattern
| PTuple of ('x core_pattern, comma) nsepseq par | PTuple of ('x core_pattern, comma) nsepseq par
constraint 'x = 'x x_sig
and 'x list_pattern = and 'x list_pattern =
Sugar of ('x core_pattern, comma) sepseq brackets Sugar of ('x core_pattern, comma) sepseq brackets
| Raw of ('x core_pattern * cons * 'x pattern) par | 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 *) (* 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 val expr_to_region : 'x expr -> Region.t

12
Parser.mly
View File

@ -171,9 +171,9 @@ type_decl:
in {region; value}} in {region; value}}
type_expr: type_expr:
cartesian { Prod (Present $1) } cartesian { Prod $1 }
| sum_type { Sum (Present $1) } | sum_type { Sum $1 }
| record_type { Record (Present $1) } | record_type { Record $1 }
cartesian: cartesian:
nsepseq(core_type,TIMES) { nsepseq(core_type,TIMES) {
@ -183,14 +183,14 @@ cartesian:
core_type: core_type:
type_name { type_name {
TAlias (Present $1) TAlias $1
} }
| type_name type_tuple { | type_name type_tuple {
let region = cover $1.region $2.region let region = cover $1.region $2.region
in TypeApp (Present {region; value = $1,$2}) in TypeApp {region; value = $1,$2}
} }
| par(type_expr) { | par(type_expr) {
ParType (Present $1) ParType $1
} }
type_tuple: type_tuple:

6
ParserMain.ml
View File

@ -57,10 +57,8 @@ let tokeniser = read ~log
let () = let () =
try try
let ast = Parser.program tokeniser buffer in let ast = Parser.program tokeniser buffer in
let () = if Utils.String.Set.mem "parser" EvalOpt.verbose if Utils.String.Set.mem "parser" EvalOpt.verbose
then Print.print_tokens ast in then Print.print_tokens ast
let _ = Typecheck2.tc_ast ast
in ()
with with
Lexer.Error err -> Lexer.Error err ->
close_all (); close_all ();

145
Print.ml
View File

@ -47,7 +47,7 @@ and print_int _visitor {region; value = lexeme, abstract} =
(* Main printing function *) (* 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; List.iter v.type_decl ast.types;
v.parameter_decl ast.parameter; v.parameter_decl ast.parameter;
v.storage_decl ast.storage; 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.block ast.block;
v.token ast.eof "EOF" 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.token node.kwd_parameter "parameter";
v.var node.name; v.var node.name;
v.token node.colon ":"; v.token node.colon ":";
v.type_expr node.param_type; v.type_expr node.param_type;
v.terminator node.terminator 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.token node.kwd_storage "storage";
v.type_expr node.store_type; v.type_expr node.store_type;
v.terminator node.terminator 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.token node.kwd_operations "operations";
v.type_expr node.op_type; v.type_expr node.op_type;
v.terminator node.terminator 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.token node.kwd_type "type";
v.var node.name; v.var node.name;
v.token node.kwd_is "is"; v.token node.kwd_is "is";
v.type_expr node.type_expr; v.type_expr node.type_expr;
v.terminator node.terminator v.terminator node.terminator
and print_type_expr (v : 'xvisitor) = function and print_type_expr (v: 'x visitor) = function
Prod (Present cartesian) -> v.cartesian cartesian Prod cartesian -> v.cartesian cartesian
| Sum (Present sum_type) -> v.sum_type sum_type | Sum sum_type -> v.sum_type sum_type
| Record (Present record_type) -> v.record_type record_type | Record record_type -> v.record_type record_type
| TypeApp (Present type_app) -> v.type_app type_app | TypeApp type_app -> v.type_app type_app
| ParType (Present par_type) -> v.par_type par_type | ParType par_type -> v.par_type par_type
| TAlias (Present type_alias) -> v.var type_alias | TAlias type_alias -> v.var type_alias
| Function _function' -> printf "TODO"
| Mutable _mutable' -> printf "TODO"
| Unit _unit' -> printf "TODO"
and print_cartesian (v : 'xvisitor) {value=sequence; _} = and print_cartesian (v: 'x visitor) {value=sequence; _} =
v.nsepseq "*" v.type_expr 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 let constr, kwd_of, cartesian = node in
v.constr constr; v.constr constr;
v.token kwd_of "of"; v.token kwd_of "of";
v.cartesian cartesian 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 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 let kwd_record, field_decls, kwd_end = node in
v.token kwd_record "record"; v.token kwd_record "record";
v.field_decls field_decls; v.field_decls field_decls;
v.token kwd_end "end" 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 let type_name, type_tuple = node in
v.var type_name; v.var type_name;
v.type_tuple type_tuple 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 let lpar, type_expr, rpar = node in
v.token lpar "("; v.token lpar "(";
v.type_expr type_expr; v.type_expr type_expr;
v.token rpar ")" v.token rpar ")"
and print_field_decls (v : 'xvisitor) sequence = and print_field_decls (v: 'x visitor) sequence =
v.nsepseq ";" v.field_decl 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 let var, colon, type_expr = node in
v.var var; v.var var;
v.token colon ":"; v.token colon ":";
v.type_expr type_expr 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 let lpar, sequence, rpar = node in
v.token lpar "("; v.token lpar "(";
v.nsepseq "," v.var sequence; v.nsepseq "," v.var sequence;
v.token rpar ")" 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 FunDecl fun_decl -> v.fun_decl fun_decl
| ProcDecl proc_decl -> v.proc_decl proc_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.token node.kwd_function "function";
v.var node.name; v.var node.name;
v.parameters node.param; v.parameters node.param;
@ -152,7 +149,7 @@ and print_fun_decl (v : 'xvisitor) {value=node; _} =
v.expr node.return; v.expr node.return;
v.terminator node.terminator 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.token node.kwd_procedure "procedure";
v.var node.name; v.var node.name;
v.parameters node.param; v.parameters node.param;
@ -161,45 +158,45 @@ and print_proc_decl (v : 'xvisitor) {value=node; _} =
v.block node.block; v.block node.block;
v.terminator node.terminator 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 let lpar, sequence, rpar = node in
v.token lpar "("; v.token lpar "(";
v.nsepseq ";" v.param_decl sequence; v.nsepseq ";" v.param_decl sequence;
v.token rpar ")" 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 ParamConst param_const -> v.param_const param_const
| ParamVar param_var -> v.param_var param_var | 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 let kwd_const, variable, colon, type_expr = node in
v.token kwd_const "const"; v.token kwd_const "const";
v.var variable; v.var variable;
v.token colon ":"; v.token colon ":";
v.type_expr type_expr 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 let kwd_var, variable, colon, type_expr = node in
v.token kwd_var "var"; v.token kwd_var "var";
v.var variable; v.var variable;
v.token colon ":"; v.token colon ":";
v.type_expr type_expr 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.token node.opening "begin";
v.instructions node.instr; v.instructions node.instr;
v.terminator node.terminator; v.terminator node.terminator;
v.token node.close "end" 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 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 LocalLam decl -> v.lambda_decl decl
| LocalConst decl -> v.const_decl decl | LocalConst decl -> v.const_decl decl
| LocalVar decl -> v.var_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.token node.kwd_const "const";
v.var node.name; v.var node.name;
v.token node.colon ":"; v.token node.colon ":";
@ -208,7 +205,7 @@ and print_const_decl (v : 'xvisitor) {value=node; _} =
v.expr node.init; v.expr node.init;
v.terminator node.terminator 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.token node.kwd_var "var";
v.var node.name; v.var node.name;
v.token node.colon ":"; v.token node.colon ":";
@ -217,14 +214,14 @@ and print_var_decl (v : 'xvisitor) {value=node; _} =
v.expr node.init; v.expr node.init;
v.terminator node.terminator v.terminator node.terminator
and print_instructions (v : 'xvisitor) {value=sequence; _} = and print_instructions (v: 'x visitor) {value=sequence; _} =
v.nsepseq ";" v.instruction 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 Single instr -> v.single_instr instr
| Block block -> v.block block | 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 Cond {value; _} -> v.conditional value
| Match {value; _} -> v.match_instr value | Match {value; _} -> v.match_instr value
| Ass instr -> v.ass_instr instr | 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" | Null kwd_null -> v.token kwd_null "null"
| Fail {value; _} -> v.fail value | 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.token kwd_fail "fail";
v.expr expr v.expr expr
and print_conditional (v : 'xvisitor) node = and print_conditional (v: 'x visitor) node =
v.token node.kwd_if "if"; v.token node.kwd_if "if";
v.expr node.test; v.expr node.test;
v.token node.kwd_then "then"; v.token node.kwd_then "then";
@ -245,43 +242,43 @@ and print_conditional (v : 'xvisitor) node =
v.token node.kwd_else "else"; v.token node.kwd_else "else";
v.instruction node.ifnot 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.token node.kwd_match "match";
v.expr node.expr; v.expr node.expr;
v.token node.kwd_with "with"; v.token node.kwd_with "with";
v.cases node.cases; v.cases node.cases;
v.token node.kwd_end "end" 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 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 let pattern, arrow, instruction = node in
v.pattern pattern; v.pattern pattern;
v.token arrow "->"; v.token arrow "->";
v.instruction instruction 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 let variable, ass, expr = node in
v.var variable; v.var variable;
v.token ass ":="; v.token ass ":=";
v.expr expr v.expr expr
and print_loop (v : 'xvisitor) = function and print_loop (v: 'x visitor) = function
While while_loop -> v.while_loop while_loop While while_loop -> v.while_loop while_loop
| For for_loop -> v.for_loop for_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 let kwd_while, expr, block = node in
v.token kwd_while "while"; v.token kwd_while "while";
v.expr expr; v.expr expr;
v.block block 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 ForInt for_int -> v.for_int for_int
| ForCollect for_collect -> v.for_collect for_collect | 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.token node.kwd_for "for";
v.ass_instr node.ass; v.ass_instr node.ass;
v.down node.down; 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.step node.step;
v.block node.block 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" Some kwd_down -> v.token kwd_down "down"
| None -> () | None -> ()
and print_step (v : 'xvisitor) = function and print_step (v: 'x visitor) = function
Some (kwd_step, expr) -> Some (kwd_step, expr) ->
v.token kwd_step "step"; v.token kwd_step "step";
v.expr expr v.expr expr
| None -> () | 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.token node.kwd_for "for";
v.var node.var; v.var node.var;
v.bind_to node.bind_to; 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.expr node.expr;
v.block node.block v.block node.block
and print_bind_to (v : 'xvisitor) = function and print_bind_to (v: 'x visitor) = function
Some (arrow, variable) -> Some (arrow, variable) ->
v.token arrow "->"; v.token arrow "->";
v.var variable v.var variable
| None -> () | None -> ()
and print_expr (v : 'xvisitor) = function and print_expr (v: 'x visitor) = function
Or {value = expr1, bool_or, expr2; _} -> Or {value = expr1, bool_or, expr2; _} ->
v.expr expr1; v.token bool_or "||"; v.expr expr2 v.expr expr1; v.token bool_or "||"; v.expr expr2
| And {value = expr1, bool_and, expr2; _} -> | And {value = expr1, bool_and, expr2; _} ->
@ -368,19 +365,19 @@ and print_expr (v : 'xvisitor) = function
| MapLookUp lookup -> v.map_lookup lookup | MapLookUp lookup -> v.map_lookup lookup
| ParExpr pexpr -> v.par_expr pexpr | 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 let lpar, sequence, rpar = node in
v.token lpar "("; v.token lpar "(";
v.nsepseq "," v.expr sequence; v.nsepseq "," v.expr sequence;
v.token rpar ")" v.token rpar ")"
and print_list (v : 'xvisitor) {value=node; _} = and print_list (v: 'x visitor) {value=node; _} =
let lbra, sequence, rbra = node in let lbra, sequence, rbra = node in
v.token lbra "["; v.token lbra "[";
v.nsepseq "," v.expr sequence; v.nsepseq "," v.expr sequence;
v.token rbra "]" 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 let lpar, (lbracket, rbracket, colon, type_expr), rpar = node in
v.token lpar "("; v.token lpar "(";
v.token lbracket "["; v.token lbracket "[";
@ -389,13 +386,13 @@ and print_empty_list (v : 'xvisitor) {value=node; _} =
v.type_expr type_expr; v.type_expr type_expr;
v.token rpar ")" v.token rpar ")"
and print_set (v : 'xvisitor) {value=node; _} = and print_set (v: 'x visitor) {value=node; _} =
let lbrace, sequence, rbrace = node in let lbrace, sequence, rbrace = node in
v.token lbrace "{"; v.token lbrace "{";
v.nsepseq "," v.expr sequence; v.nsepseq "," v.expr sequence;
v.token rbrace "}" 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 let lpar, (lbrace, rbrace, colon, type_expr), rpar = node in
v.token lpar "("; v.token lpar "(";
v.token lbrace "{"; v.token lbrace "{";
@ -404,7 +401,7 @@ and print_empty_set (v : 'xvisitor) {value=node; _} =
v.type_expr type_expr; v.type_expr type_expr;
v.token rpar ")" 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 let lpar, (c_None, colon, type_expr), rpar = node in
v.token lpar "("; v.token lpar "(";
v.token c_None "None"; v.token c_None "None";
@ -412,22 +409,22 @@ and print_none_expr (v : 'xvisitor) {value=node; _} =
v.type_expr type_expr; v.type_expr type_expr;
v.token rpar ")" 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 let fun_name, arguments = node in
v.var fun_name; v.var fun_name;
v.tuple arguments 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 let constr, arguments = node in
v.constr constr; v.constr constr;
v.tuple arguments 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 let c_Some, arguments = node in
v.token c_Some "Some"; v.token c_Some "Some";
v.tuple arguments 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 let {value = lbracket, expr, rbracket; _} = node.index in
v.var node.map_name; v.var node.map_name;
v.token node.selector "."; v.token node.selector ".";
@ -435,16 +432,16 @@ and print_map_lookup (v : 'xvisitor) {value=node; _} =
v.expr expr; v.expr expr;
v.token rbracket "]" 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 let lpar, expr, rpar = node in
v.token lpar "("; v.token lpar "(";
v.expr expr; v.expr expr;
v.token rpar ")" v.token rpar ")"
and print_pattern (v : 'xvisitor) {value=sequence; _} = and print_pattern (v: 'x visitor) {value=sequence; _} =
v.nsepseq "<:" v.core_pattern 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 PVar var -> v.var var
| PWild wild -> v.token wild "_" | PWild wild -> v.token wild "_"
| PInt i -> v.int i | PInt i -> v.int i
@ -458,28 +455,28 @@ and print_core_pattern (v : 'xvisitor) = function
| PList pattern -> v.list_pattern pattern | PList pattern -> v.list_pattern pattern
| PTuple ptuple -> v.ptuple ptuple | 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 let c_Some, patterns = node in
v.token c_Some "Some"; v.token c_Some "Some";
v.patterns patterns 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 let lpar, core_pattern, rpar = node in
v.token lpar "("; v.token lpar "(";
v.core_pattern core_pattern; v.core_pattern core_pattern;
v.token rpar ")" v.token rpar ")"
and print_list_pattern (v : 'xvisitor) = function and print_list_pattern (v: 'x visitor) = function
Sugar sugar -> v.sugar sugar Sugar sugar -> v.sugar sugar
| Raw raw -> v.raw raw | 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 let lbracket, sequence, rbracket = node in
v.token lbracket "["; v.token lbracket "[";
v.sepseq "," v.core_pattern sequence; v.sepseq "," v.core_pattern sequence;
v.token rbracket "]" 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 let lpar, (core_pattern, cons, pattern), rpar = node in
v.token lpar "("; v.token lpar "(";
v.core_pattern core_pattern; v.core_pattern core_pattern;
@ -487,13 +484,13 @@ and print_raw (v : 'xvisitor) {value=node; _} =
v.pattern pattern; v.pattern pattern;
v.token rpar ")" v.token rpar ")"
and print_ptuple (v : 'xvisitor) {value=node; _} = and print_ptuple (v: 'x visitor) {value=node; _} =
let lpar, sequence, rpar = node in let lpar, sequence, rpar = node in
v.token lpar "("; v.token lpar "(";
v.nsepseq "," v.core_pattern sequence; v.nsepseq "," v.core_pattern sequence;
v.token rpar ")" v.token rpar ")"
and print_terminator (v : 'xvisitor) = function and print_terminator (v: 'x visitor) = function
Some semi -> v.token semi ";" Some semi -> v.token semi ";"
| None -> () | None -> ()

2
Print.mli
View File

@ -2,4 +2,4 @@
open AST open AST
val print_tokens : parse_phase ast -> unit val print_tokens : t -> unit

337
Typecheck2.ml
View File

@ -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
*)

1
Typecheck2.mli
View File

@ -1 +0,0 @@
val tc_ast : AST.parse_phase AST.ast -> AST.typecheck_phase AST.ast

5
typecheck.ml
View File

@ -1,3 +1,8 @@
(* (*
module I = AST (* In *) module I = AST (* In *)