From a469d1237bc2a67d8fbf7afaeebed0702818c83c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 16:55:41 +0100 Subject: [PATCH 01/38] Removed list expressions and patterns (now nested cons), merged record and tuple --- Typecheck2.ml | 13 ++++++++----- Typecheck2.mli | 19 +++++++++++-------- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 7f1b5866c..bb5970036 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -7,6 +7,7 @@ module O = struct type type_name = string type var_name = { name: string; orig: asttodo } + type record_key = [`Field of string | `Component of int] type pattern = PVar of var_name @@ -21,7 +22,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PTuple of pattern list + | PRecord of pattern list type type_constructor = | Option @@ -30,9 +31,8 @@ module O = struct | Map type type_expr_case = - Prod of type_expr_case list | Sum of (type_name * type_expr_case) list - | Record of (type_name * type_expr_case) list + | Record of record_key type_record | TypeApp of type_constructor * (type_expr_case list) | Function of { args: type_expr_case list; ret: type_expr_case } | Ref of type_expr_case @@ -41,7 +41,7 @@ module O = struct | Int | Unit | Bool - + and 'key type_record = ('key * type_expr_case) list type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } @@ -53,8 +53,11 @@ module O = struct App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant + | Record of record_key expr_record | Lambda of lambda + and 'key expr_record = ('key * expr list) + and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } @@ -70,7 +73,7 @@ module O = struct Function of string | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not - | Tuple | Set | List + | Set | MapLookup and operator = { operator: operator_case; ty:type_expr; orig: asttodo } diff --git a/Typecheck2.mli b/Typecheck2.mli index 7f1b5866c..e8fe362f0 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -1,12 +1,13 @@ [@@@warning "-30"] -module SMap = Map.Make(String) +module SMap : Map.S with type key = string -module O = struct +module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) type type_name = string type var_name = { name: string; orig: asttodo } + type record_key = [`Field of string | `Component of int] type pattern = PVar of var_name @@ -21,7 +22,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PTuple of pattern list + | PRecord of pattern list type type_constructor = | Option @@ -30,9 +31,8 @@ module O = struct | Map type type_expr_case = - Prod of type_expr_case list | Sum of (type_name * type_expr_case) list - | Record of (type_name * type_expr_case) list + | Record of record_key type_record | TypeApp of type_constructor * (type_expr_case list) | Function of { args: type_expr_case list; ret: type_expr_case } | Ref of type_expr_case @@ -41,7 +41,7 @@ module O = struct | Int | Unit | Bool - + and 'key type_record = ('key * type_expr_case) list type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } @@ -53,8 +53,11 @@ module O = struct App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant + | Record of record_key expr_record | Lambda of lambda + and 'key expr_record = ('key * expr list) + and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } @@ -70,7 +73,7 @@ module O = struct Function of string | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not - | Tuple | Set | List + | Set | MapLookup and operator = { operator: operator_case; ty:type_expr; orig: asttodo } @@ -101,4 +104,4 @@ module O = struct } end -let temporary_force_dune = 123 +val temporary_force_dune : int From cd3eed8c2ef5176db3751cfe695c15a2d8c5b2f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 14:29:45 +0100 Subject: [PATCH 02/38] WIP on some cases --- AST2.ml | 109 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 54 insertions(+), 55 deletions(-) diff --git a/AST2.ml b/AST2.ml index 2b255f53b..9835134ab 100644 --- a/AST2.ml +++ b/AST2.ml @@ -234,7 +234,7 @@ and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr = and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region} : O.expr = let () = ignore (c_Some,l,r,region2,region) in match s_nsepseq arguments with - [] -> Constant Unit + [] -> failwith "tuple cannot be empty" | [a] -> s_expr a | l -> App { operator = Tuple; arguments = map s_expr l } @@ -246,8 +246,59 @@ and s_set {value=(l, set, r); region} : O.expr = let () = ignore (l, r, region) in App { operator = Set; arguments = map s_expr (s_nsepseq set) } -and s_case : I.case -> O.pattern * (O.instr list) = function - | _ -> raise (TODO "simplify pattern matching cases") +and s_pattern {value=sequence; region} : O.pattern = + let () = ignore (region) in + s_pattern_conses (s_nsepseq sequence) + +and s_pattern_conses : I.core_pattern list -> O.pattern = function + [] -> assert false + | [p] -> s_core_pattern p + | hd :: tl -> PCons (s_core_pattern hd, s_pattern_conses tl) + +and s_case ({value=(pattern, arrow, instruction); region} : I.case) : O.pattern * O.instr list = + let () = ignore (arrow,region) in + s_pattern pattern, s_instruction instruction + +and s_core_pattern : I.core_pattern -> O.pattern = function + PVar var -> PVar (s_name var) +| PWild wild -> let () = ignore (wild) in PWild +| PInt {value=(si,i);region} -> let () = ignore (si,region) in PInt i +| PBytes {value=(sb,b);region} -> let () = ignore (sb,region) in PBytes b +| PString {value=s;region} -> let () = ignore (region) in PString s +| PUnit region -> let () = ignore (region) in PUnit +| PFalse region -> let () = ignore (region) in PFalse +| PTrue region -> let () = ignore (region) in PTrue +| PNone region -> let () = ignore (region) in PNone +| PSome psome -> s_psome psome +| PList pattern -> s_list_pattern pattern +| PTuple ptuple -> s_ptuple ptuple + +and s_list_pattern = function + Sugar sugar -> s_sugar sugar +| Raw raw -> s_raw raw + +and s_sugar {value=(lbracket, sequence, rbracket); _} : O.pattern = + List.fold_left (fun acc p -> O.PCons (s_core_pattern p, acc)) + O.PNull + (s_sepseq sequence); + +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_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = + let () = ignore (c_Some,l,r,region2,region) in + PSome (s_core_pattern psome) and s_const_decl I.{value={kwd_const;name;colon;const_type;equal;init;terminator}; region} : O.decl = let () = ignore (kwd_const,colon,equal,terminator,region) in @@ -506,12 +557,6 @@ let s_ast (ast : I.ast) : O.ast = (* 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_expr = function *) (* Or {value = expr1, bool_or, expr2; _} -> *) (* s_expr expr1; s_token bool_or "||"; s_expr expr2 *) @@ -621,57 +666,11 @@ let s_ast (ast : I.ast) : O.ast = (* 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 ";" *) From 5ca94d13bac420fd3be532bd4c65321564d02f0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 17:10:57 +0100 Subject: [PATCH 03/38] AST2: simplified some of the pattern-matching nodes --- AST2.ml | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/AST2.ml b/AST2.ml index 9835134ab..c84021624 100644 --- a/AST2.ml +++ b/AST2.ml @@ -277,24 +277,19 @@ and s_list_pattern = function Sugar sugar -> s_sugar sugar | Raw raw -> s_raw raw -and s_sugar {value=(lbracket, sequence, rbracket); _} : O.pattern = +and s_sugar {value=(lbracket, sequence, rbracket); region} : O.pattern = + let () = ignore (lbracket, rbracket, region) in List.fold_left (fun acc p -> O.PCons (s_core_pattern p, acc)) O.PNull (s_sepseq sequence); -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_raw {value=(lpar, (core_pattern, cons, pattern), rpar); region} = + let () = ignore (lpar, cons, rpar, region) in + O.PCons (s_core_pattern core_pattern, s_pattern pattern) -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_ptuple {value=(lpar, sequence, rpar); region} = + let () = ignore (lpar, rpar, region) in + PTuple (map s_core_pattern (s_nsepseq sequence)) and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = let () = ignore (c_Some,l,r,region2,region) in From 650206ec14942b27104794b6d1ed06dde34ff8e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 21:52:59 +0100 Subject: [PATCH 04/38] AST2: tiny clean up --- AST2.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/AST2.ml b/AST2.ml index c84021624..019c3df9f 100644 --- a/AST2.ml +++ b/AST2.ml @@ -1,7 +1,5 @@ [@@@warning "-30"] -exception TODO of string - module I = AST open Region @@ -36,7 +34,6 @@ module O = struct | Ref of type_expr | Unit | Int - | TODO type typed_var = { name:var_name; ty:type_expr } @@ -94,7 +91,7 @@ let map f l = List.rev (List.rev_map f l) (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 list_to_map l = List.fold_left (fun m (k,v) -> SMap.add k v m) SMap.empty l let fold_map f a l = let f (acc, l) elem = let acc', elem' = f acc elem @@ -367,7 +364,7 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo let step = s_step step in [ Assignment { name; value = s_expr expr }; - (* TODO: lift the declaration of the variable *) + (* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *) While { condition = App { operator = condition; arguments = [Var name; s_expr bound] }; From cf80ccd9a21c29b8297b920e26cba0efeda24bed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 23:42:16 +0100 Subject: [PATCH 05/38] Small tweak on the typed AST --- Typecheck2.ml | 9 ++++++--- Typecheck2.mli | 9 ++++++--- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index bb5970036..6a5014102 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -5,8 +5,9 @@ module SMap = Map.Make(String) module O = struct type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = string - type var_name = { name: string; orig: asttodo } + type type_name = {name: string; orig: Region.t} + type var_name = type_name + type record_key = [`Field of string | `Component of int] type pattern = @@ -22,7 +23,9 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of pattern list + | PRecord of record_key precord + + and 'key precord = ('key * pattern) list type type_constructor = | Option diff --git a/Typecheck2.mli b/Typecheck2.mli index e8fe362f0..777a40a1b 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -5,8 +5,9 @@ module SMap : Map.S with type key = string module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = string - type var_name = { name: string; orig: asttodo } + type type_name = {name: string; orig: Region.t} + type var_name = type_name + type record_key = [`Field of string | `Component of int] type pattern = @@ -22,7 +23,9 @@ module O : sig | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of pattern list + | PRecord of record_key precord + + and 'key precord = ('key * pattern) list type type_constructor = | Option From 6f1142d8f8fbed15111a80e2fcfed0b115d11930 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 13 Mar 2019 23:42:34 +0100 Subject: [PATCH 06/38] WIP on adding orig --- AST2.ml | 87 ++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 58 insertions(+), 29 deletions(-) diff --git a/AST2.ml b/AST2.ml index 019c3df9f..62c2a88af 100644 --- a/AST2.ml +++ b/AST2.ml @@ -7,8 +7,12 @@ open Region module SMap = Map.Make(String) module O = struct - type type_name = string - type var_name = string + type asttodo = [`TODO] + + type type_name = {name: string; orig: Region.t} + type var_name = type_name + + type record_key = [`Field of string | `Component of int] type pattern = PVar of var_name @@ -23,21 +27,28 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PTuple of pattern list + | PRecord of record_key precord - type type_expr = + and 'key precord = ('key * pattern) list + + type type_expr_case = 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 + | String | Int + | Unit + | Bool + and 'key type_record = ('key * type_expr) list + + and type_expr = { type_expr: type_expr_case; name: type_name option; orig: AST.type_expr } type typed_var = { name:var_name; ty:type_expr } - type type_decl = { name:string; ty:type_expr } + type type_decl = { name:type_name; ty:type_expr } type expr = App of { operator: operator; arguments: expr list } @@ -59,7 +70,7 @@ module O = struct | Neg | Not | Tuple | Set | List | MapLookup - | Function of string + | Function of var_name and constant = Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True @@ -87,8 +98,12 @@ 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 mapi f l = + let f (i, l) elem = + (i + 1, (f i elem) :: l) + in snd (List.fold_left f (0,[]) l) +(* TODO: check that List.append is not broken + (i.e. check that it is 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 = List.fold_left (fun m (k,v) -> SMap.add k v m) SMap.empty l @@ -110,22 +125,29 @@ let s_sepseq : ('a,'sep) Utils.sepseq -> 'a list = | Some nsepseq -> s_nsepseq nsepseq let s_name {value=name; region} : O.var_name = + let () = ignore (region) in + {name;orig = region} + +let name_to_string {value=name; region} : string = let () = ignore (region) in name -let rec s_cartesian {value=sequence; region} : O.type_expr = +let type_expr (orig : I.type_expr) (e : O.type_expr_case) : O.type_expr = + { type_expr = e; name = None; orig } + +let rec s_cartesian {value=sequence; region} : O.type_expr_case = let () = ignore (region) in Prod (map s_type_expr (s_nsepseq sequence)) -and s_sum_type {value=sequence; region} : O.type_expr = +and s_sum_type {value=sequence; region} : O.type_expr_case = let () = ignore (region) in Sum (map s_variant (s_nsepseq sequence)) and s_variant {value=(constr, kwd_of, cartesian); region} = let () = ignore (kwd_of,region) in - (s_name constr, s_cartesian cartesian) + (s_name constr, type_expr "_" (s_cartesian cartesian)) -and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = +and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr_case = let () = ignore (kwd_record,region,kwd_end) in Record (map s_field_decl (s_nsepseq field_decls)) @@ -133,7 +155,7 @@ and s_field_decl {value=(var, colon, type_expr); region} = let () = ignore (colon,region) in (s_name var, s_type_expr type_expr) -and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = +and s_type_app {value=(type_name,type_tuple); region} : O.type_expr_case = let () = ignore (region) in TypeApp (s_name type_name, s_type_tuple type_tuple) @@ -146,22 +168,23 @@ and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr = let () = ignore (lpar,rpar,region) in s_type_expr type_expr -and s_type_alias name : O.type_expr = +and s_type_alias name : O.type_expr_case = let () = ignore () in TypeApp (s_name name, []) -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 +and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with + Prod cartesian -> type_expr orig (s_cartesian cartesian) +| Sum sum_type -> type_expr orig (s_sum_type sum_type) +| Record record_type -> type_expr orig (s_record_type record_type) +| TypeApp type_app -> type_expr orig (s_type_app type_app) | ParType par_type -> s_par_type par_type -| TAlias type_alias -> s_type_alias type_alias +| TAlias type_alias -> type_expr orig (s_type_alias type_alias) 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 } + let ty = s_type_expr type_expr in + O.{ name = s_name name; ty = { ty with name = Some (s_name name) } } let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var = let () = ignore (kwd_storage,colon,terminator,region) in @@ -205,7 +228,7 @@ and s_expr : I.expr -> O.expr = | Neg {value=(minus, expr); region} -> let () = ignore (region, minus) in una Neg expr | Not {value=(kwd_not, expr); region} -> let () = ignore (region, kwd_not) in una Not expr | Int {value=(lexeme, z); region} -> let () = ignore (region, lexeme) in Constant (Int z) - | Var {value=lexeme; region} -> let () = ignore (region) in Var lexeme + | Var lexeme -> Var (s_name lexeme) | String {value=s; region} -> let () = ignore (region) in Constant (String s) | Bytes {value=(lexeme, mbytes); region} -> let () = ignore (region, lexeme) in Constant (Bytes mbytes) | False c_False -> let () = ignore (c_False) in Constant (False) @@ -286,7 +309,10 @@ and s_raw {value=(lpar, (core_pattern, cons, pattern), rpar); region} = and s_ptuple {value=(lpar, sequence, rpar); region} = let () = ignore (lpar, rpar, region) in - PTuple (map s_core_pattern (s_nsepseq sequence)) + s_nsepseq sequence + |> map s_core_pattern + |> mapi (fun i p -> `Component i, p) + |> fun x -> O.PRecord x and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = let () = ignore (c_Some,l,r,region2,region) in @@ -298,11 +324,11 @@ and s_const_decl I.{value={kwd_const;name;colon;const_type;equal;init;terminator and 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 + name_to_string variable, s_type_expr type_expr and 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 + name_to_string variable, s_type_expr type_expr and s_param_decl : I.param_decl -> string * O.type_expr = function ParamConst p -> s_param_const p @@ -435,7 +461,8 @@ and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_dec 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 }; + ty = type_expr "_" (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; @@ -448,7 +475,8 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term let () = ignore (kwd_procedure,kwd_is,terminator,region) in O.{ name = s_name name; - ty = Function { args = map snd (s_parameters param); ret = Unit }; + ty = type_expr "_" (Function { args = map snd (s_parameters param); + ret = type_expr "_" Unit }); value = Lambda { parameters = s_parameters param |> list_to_map; declarations = map s_local_decl local_decls; @@ -461,7 +489,8 @@ and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;te let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in O.{ name = s_name name; - ty = Function { args = map snd (s_parameters param); ret = Unit }; + ty = type_expr "_" (Function { args = map snd (s_parameters param); + ret = type_expr "_" Unit }); value = Lambda { parameters = s_parameters param |> list_to_map; declarations = map s_local_decl local_decls; From df4f49111bc69017f4ea9c1bb2c15920889f4207 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 09:37:10 +0100 Subject: [PATCH 07/38] Added regions to type_expr. The regions picked are fairly imprecise. --- AST2.ml | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/AST2.ml b/AST2.ml index 62c2a88af..bbcda7871 100644 --- a/AST2.ml +++ b/AST2.ml @@ -44,7 +44,7 @@ module O = struct | Bool and 'key type_record = ('key * type_expr) list - and type_expr = { type_expr: type_expr_case; name: type_name option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr } @@ -132,32 +132,32 @@ let name_to_string {value=name; region} : string = let () = ignore (region) in name -let type_expr (orig : I.type_expr) (e : O.type_expr_case) : O.type_expr = +let type_expr (orig : Region.t) (e : O.type_expr_case) : O.type_expr = { type_expr = e; name = None; orig } -let rec s_cartesian {value=sequence; region} : O.type_expr_case = +let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in - Prod (map s_type_expr (s_nsepseq sequence)) + type_expr region (Prod (map s_type_expr (s_nsepseq sequence))) -and s_sum_type {value=sequence; region} : O.type_expr_case = +and s_sum_type {value=sequence; region} : O.type_expr = let () = ignore (region) in - Sum (map s_variant (s_nsepseq sequence)) + type_expr region (Sum (map s_variant (s_nsepseq sequence))) and s_variant {value=(constr, kwd_of, cartesian); region} = let () = ignore (kwd_of,region) in - (s_name constr, type_expr "_" (s_cartesian cartesian)) + (s_name constr, s_cartesian cartesian) -and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr_case = +and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = let () = ignore (kwd_record,region,kwd_end) in - Record (map s_field_decl (s_nsepseq field_decls)) + type_expr region (Record (map s_field_decl (s_nsepseq field_decls))) and s_field_decl {value=(var, colon, type_expr); region} = let () = ignore (colon,region) in (s_name var, s_type_expr type_expr) -and s_type_app {value=(type_name,type_tuple); region} : O.type_expr_case = +and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in - TypeApp (s_name type_name, s_type_tuple type_tuple) + type_expr region (TypeApp (s_name type_name, s_type_tuple type_tuple)) and s_type_tuple ({value=(lpar, sequence, rpar); region} : (I.type_name, I.comma) Utils.nsepseq I.par) : O.type_expr list = let () = ignore (lpar,rpar,region) in @@ -168,17 +168,17 @@ and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr = let () = ignore (lpar,rpar,region) in s_type_expr type_expr -and s_type_alias name : O.type_expr_case = +and s_type_alias name : O.type_expr = let () = ignore () in - TypeApp (s_name name, []) + type_expr name.region (TypeApp (s_name name, [])) and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with - Prod cartesian -> type_expr orig (s_cartesian cartesian) -| Sum sum_type -> type_expr orig (s_sum_type sum_type) -| Record record_type -> type_expr orig (s_record_type record_type) -| TypeApp type_app -> type_expr orig (s_type_app type_app) + 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 -> type_expr orig (s_type_alias type_alias) +| TAlias type_alias -> s_type_alias type_alias let s_type_decl I.{value={kwd_type;name;kwd_is;type_expr;terminator}; region} : O.type_decl = @@ -461,8 +461,8 @@ and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_dec let () = ignore (kwd_function,colon,kwd_is,kwd_with,terminator,region) in O.{ name = s_name name; - ty = type_expr "_" (Function { args = map snd (s_parameters param); - ret = s_type_expr ret_type }); + ty = type_expr region (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; @@ -475,8 +475,8 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term let () = ignore (kwd_procedure,kwd_is,terminator,region) in O.{ name = s_name name; - ty = type_expr "_" (Function { args = map snd (s_parameters param); - ret = type_expr "_" Unit }); + ty = type_expr region (Function { args = map snd (s_parameters param); + ret = type_expr region Unit }); value = Lambda { parameters = s_parameters param |> list_to_map; declarations = map s_local_decl local_decls; @@ -489,8 +489,8 @@ and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;te let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in O.{ name = s_name name; - ty = type_expr "_" (Function { args = map snd (s_parameters param); - ret = type_expr "_" Unit }); + ty = type_expr region (Function { args = map snd (s_parameters param); + ret = type_expr region Unit }); value = Lambda { parameters = s_parameters param |> list_to_map; declarations = map s_local_decl local_decls; From 96fb7c7ea2e63c3cbe87151945ff28f7824cd410 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 10:58:15 +0100 Subject: [PATCH 08/38] Updated the typed AST interface after discussion with gabriel.alfour --- Typecheck2.ml | 13 +++++++------ Typecheck2.mli | 13 +++++++------ 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 6a5014102..1d820c9fa 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -37,7 +37,7 @@ module O = struct | Sum of (type_name * type_expr_case) list | Record of record_key type_record | TypeApp of type_constructor * (type_expr_case list) - | Function of { args: type_expr_case list; ret: type_expr_case } + | Function of { arg: type_expr_case; ret: type_expr_case } | Ref of type_expr_case | TC of type_constructor | String @@ -73,7 +73,10 @@ module O = struct } and operator_case = - Function of string + Function of var_name + | Construcor of var_name + | UpdateField of record_key + | GetField of record_key | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set @@ -92,16 +95,14 @@ module O = struct and instr = Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } - | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } - | DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; orig: AST.t } diff --git a/Typecheck2.mli b/Typecheck2.mli index 777a40a1b..463cbffc3 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -37,7 +37,7 @@ module O : sig | Sum of (type_name * type_expr_case) list | Record of record_key type_record | TypeApp of type_constructor * (type_expr_case list) - | Function of { args: type_expr_case list; ret: type_expr_case } + | Function of { arg: type_expr_case; ret: type_expr_case } | Ref of type_expr_case | TC of type_constructor | String @@ -73,7 +73,10 @@ module O : sig } and operator_case = - Function of string + Function of var_name + | Construcor of var_name + | UpdateField of record_key + | GetField of record_key | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set @@ -92,16 +95,14 @@ module O : sig and instr = Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } - | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } - | DropUnit of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; orig: AST.t } From 2c0b6b518c6da1ca1e29da7f2605b841377e0fe6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 11:19:15 +0100 Subject: [PATCH 09/38] =?UTF-8?q?Simplified=20Prod=20=E2=86=92=20Record=20?= =?UTF-8?q?in=20types,=20added=20region=20to=20field=20names.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- AST2.ml | 27 +++++++++++++++++++-------- Typecheck2.ml | 8 +++++--- Typecheck2.mli | 8 +++++--- 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/AST2.ml b/AST2.ml index bbcda7871..a2a7633de 100644 --- a/AST2.ml +++ b/AST2.ml @@ -9,10 +9,12 @@ module SMap = Map.Make(String) module O = struct type asttodo = [`TODO] - type type_name = {name: string; orig: Region.t} - type var_name = type_name + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region - type record_key = [`Field of string | `Component of int] + type record_key = [`Field of field_name | `Component of int] type pattern = PVar of var_name @@ -31,10 +33,15 @@ module O = struct and 'key precord = ('key * pattern) list + type type_constructor = + Option + | List + | Set + | Map + type type_expr_case = - Prod of type_expr list - | Sum of (type_name * type_expr) list - | Record of (type_name * type_expr) list + Sum of (type_name * type_expr) list + | Record of (record_key * type_expr) list | TypeApp of type_name * (type_expr list) | Function of { args: type_expr list; ret: type_expr } | Ref of type_expr @@ -137,7 +144,11 @@ let type_expr (orig : Region.t) (e : O.type_expr_case) : O.type_expr = let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in - type_expr region (Prod (map s_type_expr (s_nsepseq sequence))) + s_nsepseq sequence + |>map s_type_expr + |> mapi (fun i p -> `Component i, p) + |> (fun x -> (Record x : O.type_expr_case)) + |> type_expr region and s_sum_type {value=sequence; region} : O.type_expr = let () = ignore (region) in @@ -153,7 +164,7 @@ and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_ex and s_field_decl {value=(var, colon, type_expr); region} = let () = ignore (colon,region) in - (s_name var, s_type_expr type_expr) + (`Field (s_name var), s_type_expr type_expr) and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in diff --git a/Typecheck2.ml b/Typecheck2.ml index 1d820c9fa..252407485 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -5,10 +5,12 @@ module SMap = Map.Make(String) module O = struct type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = {name: string; orig: Region.t} - type var_name = type_name + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region - type record_key = [`Field of string | `Component of int] + type record_key = [`Field of field_name | `Component of int] type pattern = PVar of var_name diff --git a/Typecheck2.mli b/Typecheck2.mli index 463cbffc3..41a87b1c7 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -5,10 +5,12 @@ module SMap : Map.S with type key = string module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) - type type_name = {name: string; orig: Region.t} - type var_name = type_name + type name_and_region = {name: string; orig: Region.t} + type type_name = name_and_region + type var_name = name_and_region + type field_name = name_and_region - type record_key = [`Field of string | `Component of int] + type record_key = [`Field of field_name | `Component of int] type pattern = PVar of var_name From 87386c2500c1a6a3b636b3304a9687a9e5bea45c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 11:49:42 +0100 Subject: [PATCH 10/38] type_constructor in AST2.ml --- AST2.ml | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/AST2.ml b/AST2.ml index a2a7633de..42ec0fe4e 100644 --- a/AST2.ml +++ b/AST2.ml @@ -41,8 +41,8 @@ module O = struct type type_expr_case = Sum of (type_name * type_expr) list - | Record of (record_key * type_expr) list - | TypeApp of type_name * (type_expr list) + | Record of record_key type_record + | TypeApp of type_constructor * (type_expr list) | Function of { args: type_expr list; ret: type_expr } | Ref of type_expr | String @@ -142,6 +142,16 @@ let name_to_string {value=name; region} : string = let type_expr (orig : Region.t) (e : O.type_expr_case) : O.type_expr = { type_expr = e; name = None; orig } +let s_type_constructor {value=name;region} : O.type_constructor = + let () = ignore (region) in + match name with + "Option" -> Option + | "List" -> List + | "Map" -> Map + | "Set" -> Set + (* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *) + | _ -> failwith ("Unknown type constructor: " ^ name) + let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in s_nsepseq sequence @@ -168,7 +178,7 @@ and s_field_decl {value=(var, colon, type_expr); region} = and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in - type_expr region (TypeApp (s_name type_name, s_type_tuple type_tuple)) + type_expr region (TypeApp (s_type_constructor type_name, s_type_tuple type_tuple)) and s_type_tuple ({value=(lpar, sequence, rpar); region} : (I.type_name, I.comma) Utils.nsepseq I.par) : O.type_expr list = let () = ignore (lpar,rpar,region) in @@ -181,7 +191,7 @@ and s_par_type {value=(lpar, type_expr, rpar); region} : O.type_expr = and s_type_alias name : O.type_expr = let () = ignore () in - type_expr name.region (TypeApp (s_name name, [])) + type_expr name.region (TypeApp (s_type_constructor name, [])) and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with Prod cartesian -> s_cartesian cartesian From 97db2a431c49b0866bc2bcbc73e045d938463ec0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 11:50:18 +0100 Subject: [PATCH 11/38] type_expr vs. type_expr_case (put the regions and names in more places) in Typecheck2.mli --- Typecheck2.ml | 12 ++++++------ Typecheck2.mli | 14 +++++++------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 252407485..027797091 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -36,19 +36,19 @@ module O = struct | Map type type_expr_case = - | Sum of (type_name * type_expr_case) list + | Sum of (type_name * type_expr) list | Record of record_key type_record - | TypeApp of type_constructor * (type_expr_case list) - | Function of { arg: type_expr_case; ret: type_expr_case } - | Ref of type_expr_case + | TypeApp of type_constructor * (type_expr list) + | Function of { arg: type_expr; ret: type_expr } + | Ref of type_expr | TC of type_constructor | String | Int | Unit | Bool - and 'key type_record = ('key * type_expr_case) list + and 'key type_record = ('key * type_expr) list - type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } diff --git a/Typecheck2.mli b/Typecheck2.mli index 41a87b1c7..d90558afb 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -30,25 +30,25 @@ module O : sig and 'key precord = ('key * pattern) list type type_constructor = - | Option + Option | List | Set | Map type type_expr_case = - | Sum of (type_name * type_expr_case) list + Sum of (type_name * type_expr) list | Record of record_key type_record - | TypeApp of type_constructor * (type_expr_case list) - | Function of { arg: type_expr_case; ret: type_expr_case } - | Ref of type_expr_case + | TypeApp of type_constructor * (type_expr list) + | Function of { arg: type_expr; ret: type_expr } + | Ref of type_expr | TC of type_constructor | String | Int | Unit | Bool - and 'key type_record = ('key * type_expr_case) list + and 'key type_record = ('key * type_expr) list - type type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } From 1db0f7c1fe5e763afc80c42168a84274a384b152 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 11:59:14 +0100 Subject: [PATCH 12/38] Wrong nesting of key and expr in records --- Typecheck2.ml | 2 +- Typecheck2.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 027797091..5c432f2e8 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -61,7 +61,7 @@ module O = struct | Record of record_key expr_record | Lambda of lambda - and 'key expr_record = ('key * expr list) + and 'key expr_record = ('key * expr) list and expr = { expr: expr_case; ty:type_expr; orig: asttodo } diff --git a/Typecheck2.mli b/Typecheck2.mli index d90558afb..1f14aba31 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -61,7 +61,7 @@ module O : sig | Record of record_key expr_record | Lambda of lambda - and 'key expr_record = ('key * expr list) + and 'key expr_record = ('key * expr) list and expr = { expr: expr_case; ty:type_expr; orig: asttodo } From 8a11fc71eb94aa9cba3c455268051cb7f490760b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 12:30:51 +0100 Subject: [PATCH 13/38] Removed non-applied type_constructor, single parameter for lambda expression. --- Typecheck2.ml | 3 +-- Typecheck2.mli | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 5c432f2e8..914bfd779 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -41,7 +41,6 @@ module O = struct | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr - | TC of type_constructor | String | Int | Unit @@ -68,7 +67,7 @@ module O = struct and decl = { var: typed_var; value: expr; orig: asttodo } and lambda = { - parameters: typed_var SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; diff --git a/Typecheck2.mli b/Typecheck2.mli index 1f14aba31..e301a5d0b 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -41,7 +41,6 @@ module O : sig | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr - | TC of type_constructor | String | Int | Unit @@ -68,7 +67,7 @@ module O : sig and decl = { var: typed_var; value: expr; orig: asttodo } and lambda = { - parameters: typed_var SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; From 332f18bb8087c17887cb14563c0f6382347db4f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 16:15:42 +0100 Subject: [PATCH 14/38] Single argument for lambdas --- AST2.ml | 73 ++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 57 insertions(+), 16 deletions(-) diff --git a/AST2.ml b/AST2.ml index 42ec0fe4e..c91612138 100644 --- a/AST2.ml +++ b/AST2.ml @@ -43,7 +43,7 @@ module O = struct Sum of (type_name * type_expr) list | Record of record_key type_record | TypeApp of type_constructor * (type_expr list) - | Function of { args: type_expr list; ret: type_expr } + | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr | String | Int @@ -59,25 +59,28 @@ module O = struct type expr = App of { operator: operator; arguments: expr list } - | Var of var_name + | Var of var_name | Constant of constant | Lambda of lambda and decl = { name:var_name; ty:type_expr; value: expr } and lambda = { - parameters: type_expr SMap.t; + parameter: typed_var; declarations: decl list; instructions: instr list; result: expr; } and operator = - Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod + Function of var_name + | Construcor of var_name + | UpdateField of record_key + | GetField of record_key + | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Tuple | Set | List | MapLookup - | Function of var_name and constant = Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True @@ -227,6 +230,18 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let () = ignore (l, c_None, colon, r, region) in Constant (CNone (s_type_expr type_expr)) +let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = + (* TODO: use records with named fields to have named arguments. *) + let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in + O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } +and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = + let f i (name,ty) = + O.{ name = {name; orig=Region.ghost}; + ty = ty; + value = App { operator = O.GetField (`Component i); + arguments = [Var singleparam] } } + in mapi f parameters + let rec bin l operator r = O.App { operator; arguments = [s_expr l; s_expr r] } and una operator v = O.App { operator; arguments = [s_expr v] } and s_expr : I.expr -> O.expr = @@ -453,9 +468,13 @@ and s_constr_app {value=(constr, arguments); region} : O.expr = let () = ignore (region) in App { operator = Function (s_name constr); arguments = s_arguments arguments } -and s_arguments {value=(lpar, sequence, rpar); region} = +and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = + (* TODO: should return a tuple *) let () = ignore (lpar,rpar,region) in - map s_expr (s_nsepseq sequence); + match map s_expr (s_nsepseq sequence) with + [] -> [Constant Unit] + | [single_argument] -> [single_argument] + | args -> [App { operator = Tuple; arguments = args }] ; and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in @@ -478,15 +497,27 @@ and s_block I.{value={opening;instr;terminator;close}; _} : O.instr list = let () = ignore (opening,terminator,close) in s_instructions instr +and gensym = + let i = ref 0 in + fun ty -> + i := !i + 1; + (* TODO: Region.ghost *) + ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var) + 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 + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = s_type_expr ret_type }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = s_expr return } @@ -494,13 +525,18 @@ and s_fun_decl I.{value={kwd_function;name;param;colon;ret_type;kwd_is;local_dec 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 + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit } @@ -508,13 +544,18 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;terminator}; region} = let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in + let tuple_type = s_parameters param |> parameters_to_tuple in + let single_argument = gensym tuple_type in + let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in O.{ name = s_name name; - ty = type_expr region (Function { args = map snd (s_parameters param); + ty = type_expr region (Function { arg = tuple_type; ret = type_expr region Unit }); value = Lambda { - parameters = s_parameters param |> list_to_map; - declarations = map s_local_decl local_decls; + parameter = single_argument; + declarations = append + (s_parameters param |> parameters_to_decls single_argument_xxx) + (map s_local_decl local_decls); instructions = s_block block; result = O.Constant O.Unit } From 9c5d31eca15b42f08e0dafc0bb144e6fe9255750 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 16:46:18 +0100 Subject: [PATCH 15/38] Merged tuples and records so that x.4 is valid in principle --- Typecheck2.ml | 21 +++++++-------------- Typecheck2.mli | 17 +++++------------ 2 files changed, 12 insertions(+), 26 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 914bfd779..3edc1b66b 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -10,8 +10,6 @@ module O = struct type var_name = name_and_region type field_name = name_and_region - type record_key = [`Field of field_name | `Component of int] - type pattern = PVar of var_name | PWild @@ -25,19 +23,17 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of record_key precord - - and 'key precord = ('key * pattern) list + | PRecord of (field_name * pattern) list type type_constructor = - | Option + Option | List | Set | Map type type_expr_case = - | Sum of (type_name * type_expr) list - | Record of record_key type_record + Sum of (type_name * type_expr) list + | Record of (field_name * type_expr) list | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -45,7 +41,6 @@ module O = struct | Int | Unit | Bool - and 'key type_record = ('key * type_expr) list and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } @@ -57,11 +52,9 @@ module O = struct App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant - | Record of record_key expr_record + | Record of (field_name * expr) list | Lambda of lambda - and 'key expr_record = ('key * expr) list - and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } @@ -76,8 +69,8 @@ module O = struct and operator_case = Function of var_name | Construcor of var_name - | UpdateField of record_key - | GetField of record_key + | UpdateField of field_name + | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set diff --git a/Typecheck2.mli b/Typecheck2.mli index e301a5d0b..a85ddba8b 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -10,8 +10,6 @@ module O : sig type var_name = name_and_region type field_name = name_and_region - type record_key = [`Field of field_name | `Component of int] - type pattern = PVar of var_name | PWild @@ -25,9 +23,7 @@ module O : sig | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of record_key precord - - and 'key precord = ('key * pattern) list + | PRecord of (field_name * pattern) list type type_constructor = Option @@ -37,7 +33,7 @@ module O : sig type type_expr_case = Sum of (type_name * type_expr) list - | Record of record_key type_record + | Record of (field_name * type_expr) list | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -45,7 +41,6 @@ module O : sig | Int | Unit | Bool - and 'key type_record = ('key * type_expr) list and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } @@ -57,11 +52,9 @@ module O : sig App of { operator: operator; arguments: expr list } | Var of typed_var | Constant of constant - | Record of record_key expr_record + | Record of (field_name * expr) list | Lambda of lambda - and 'key expr_record = ('key * expr) list - and expr = { expr: expr_case; ty:type_expr; orig: asttodo } and decl = { var: typed_var; value: expr; orig: asttodo } @@ -76,8 +69,8 @@ module O : sig and operator_case = Function of var_name | Construcor of var_name - | UpdateField of record_key - | GetField of record_key + | UpdateField of field_name + | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Set From e1ad18cd3e0030a6ff47abdadeac9306c12b72c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 17:58:14 +0100 Subject: [PATCH 16/38] Merged tuples and records so that x.4 is valid in principle --- AST2.ml | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/AST2.ml b/AST2.ml index c91612138..04092cc0b 100644 --- a/AST2.ml +++ b/AST2.ml @@ -14,8 +14,6 @@ module O = struct type var_name = name_and_region type field_name = name_and_region - type record_key = [`Field of field_name | `Component of int] - type pattern = PVar of var_name | PWild @@ -29,9 +27,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of record_key precord - - and 'key precord = ('key * pattern) list + | PRecord of (field_name * pattern) list type type_constructor = Option @@ -41,7 +37,7 @@ module O = struct type type_expr_case = Sum of (type_name * type_expr) list - | Record of record_key type_record + | Record of (field_name * type_expr) list | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -75,8 +71,8 @@ module O = struct and operator = Function of var_name | Construcor of var_name - | UpdateField of record_key - | GetField of record_key + | UpdateField of field_name + | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod | Neg | Not | Tuple | Set | List @@ -126,6 +122,8 @@ let fold_map f a l = (* Simplify the AST *) +let name_and_region_of_int i = O.{name = string_of_int i; orig = Region.ghost} + let s_nsepseq : ('a,'sep) Utils.nsepseq -> 'a list = fun (first, rest) -> first :: (map snd rest) @@ -159,7 +157,7 @@ let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in s_nsepseq sequence |>map s_type_expr - |> mapi (fun i p -> `Component i, p) + |> mapi (fun i p -> name_and_region_of_int i, p) |> (fun x -> (Record x : O.type_expr_case)) |> type_expr region @@ -173,11 +171,11 @@ and s_variant {value=(constr, kwd_of, cartesian); region} = and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = let () = ignore (kwd_record,region,kwd_end) in - type_expr region (Record (map s_field_decl (s_nsepseq field_decls))) + type_expr region (Record (map s_field_decl (s_nsepseq field_decls)) : O.type_expr_case) -and s_field_decl {value=(var, colon, type_expr); region} = +and s_field_decl {value=(var, colon, type_expr); region} : O.type_name * O.type_expr = let () = ignore (colon,region) in - (`Field (s_name var), s_type_expr type_expr) + ((s_name var), (s_type_expr type_expr)) and s_type_app {value=(type_name,type_tuple); region} : O.type_expr = let () = ignore (region) in @@ -232,13 +230,13 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = (* TODO: use records with named fields to have named arguments. *) - let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> `Component i, ty) parameters) in + let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters) in O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = let f i (name,ty) = O.{ name = {name; orig=Region.ghost}; ty = ty; - value = App { operator = O.GetField (`Component i); + value = App { operator = O.GetField (name_and_region_of_int i); arguments = [Var singleparam] } } in mapi f parameters @@ -347,7 +345,7 @@ and s_ptuple {value=(lpar, sequence, rpar); region} = let () = ignore (lpar, rpar, region) in s_nsepseq sequence |> map s_core_pattern - |> mapi (fun i p -> `Component i, p) + |> mapi (fun i p -> name_and_region_of_int i, p) |> fun x -> O.PRecord x and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = From fbf6e5d89fe8412cd9e55535f4bc640e2c300945 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:05:07 +0100 Subject: [PATCH 17/38] Cleanup --- AST2.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/AST2.ml b/AST2.ml index 04092cc0b..480764e90 100644 --- a/AST2.ml +++ b/AST2.ml @@ -7,7 +7,7 @@ open Region module SMap = Map.Make(String) module O = struct - type asttodo = [`TODO] + type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) type name_and_region = {name: string; orig: Region.t} type type_name = name_and_region @@ -45,7 +45,6 @@ module O = struct | Int | Unit | Bool - and 'key type_record = ('key * type_expr) list and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } From 03671802ebcd52841bcd4fd612fc1473e943a8f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:05:24 +0100 Subject: [PATCH 18/38] DropUnit is now ProcedureCall --- AST2.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/AST2.ml b/AST2.ml index 480764e90..5b6b62414 100644 --- a/AST2.ml +++ b/AST2.ml @@ -87,7 +87,7 @@ module O = struct | 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. *) + | ProcedureCall of expr (* expr returns unit, drop the result. *) | Fail of { expr: expr } type ast = { @@ -485,7 +485,7 @@ and s_single_instr : I.single_instr -> O.instr list = function | 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)] +| ProcCall fun_call -> [ProcedureCall (s_fun_call fun_call)] | Null kwd_null -> let () = ignore (kwd_null) in [] | Fail {value; _} -> [s_fail value] From 9db37fbdc4799231c7310116ced0b336ff5375dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:05:57 +0100 Subject: [PATCH 19/38] operations_decl is now disallowed --- AST2.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/AST2.ml b/AST2.ml index 5b6b62414..4cf261b31 100644 --- a/AST2.ml +++ b/AST2.ml @@ -93,7 +93,6 @@ module O = struct type ast = { types : type_decl list; storage_decl : typed_var; - operations_decl : typed_var; declarations : decl list; } end @@ -591,10 +590,10 @@ let s_ast (ast : I.ast) : O.ast = let storage_decl = match storage_decl with Some x -> x | None -> failwith "Missing storage declaration" in - let operations_decl = match operations_decl with - Some x -> x - | None -> failwith "Missing storage declaration" - in {types; storage_decl; operations_decl; declarations} + let () = match operations_decl with + Some _ -> failwith "Operations declaration is not allowed anymore TODO" + | None -> () + in {types; storage_decl; declarations} From cbb08f440549c00ece8851210c1b865900a211ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:19:51 +0100 Subject: [PATCH 20/38] Humour. --- Typecheck2.ml | 2 +- Typecheck2.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 3edc1b66b..726775164 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -68,7 +68,7 @@ module O = struct and operator_case = Function of var_name - | Construcor of var_name + | Constructor of var_name | UpdateField of field_name | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod diff --git a/Typecheck2.mli b/Typecheck2.mli index a85ddba8b..6da40fa1e 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -68,7 +68,7 @@ module O : sig and operator_case = Function of var_name - | Construcor of var_name + | Constructor of var_name | UpdateField of field_name | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod From 5628e370b53a075c69b714fe3b2d52c854d93119 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:26:25 +0100 Subject: [PATCH 21/38] Indentation to match Typecheck2.mli --- AST2.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/AST2.ml b/AST2.ml index 4cf261b31..c19df17f7 100644 --- a/AST2.ml +++ b/AST2.ml @@ -68,14 +68,14 @@ module O = struct } and operator = - Function of var_name - | Construcor of var_name - | UpdateField of field_name - | GetField of field_name - | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod - | Neg | Not - | Tuple | Set | List - | MapLookup + Function of var_name + | Construcor of var_name + | UpdateField of field_name + | GetField of field_name + | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod + | Neg | Not + | Set | List + | MapLookup and constant = Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True From 9b6d93b343a9d2df0a3d5aa032ddfb90d1f295ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:26:36 +0100 Subject: [PATCH 22/38] Replace tuples with records --- AST2.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/AST2.ml b/AST2.ml index c19df17f7..7b99dad71 100644 --- a/AST2.ml +++ b/AST2.ml @@ -56,6 +56,7 @@ module O = struct App of { operator: operator; arguments: expr list } | Var of var_name | Constant of constant + | Record of (field_name * expr) list | Lambda of lambda and decl = { name:var_name; ty:type_expr; value: expr } @@ -228,8 +229,10 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = (* TODO: use records with named fields to have named arguments. *) - let parameter_tuple = O.Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters) in + let parameter_tuple : O.type_expr_case = + Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters) in O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } + and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = let f i (name,ty) = O.{ name = {name; orig=Region.ghost}; @@ -266,7 +269,7 @@ and s_expr : I.expr -> O.expr = | False c_False -> let () = ignore (c_False) in Constant (False) | True c_True -> let () = ignore (c_True) in Constant (True) | Unit c_Unit -> let () = ignore (c_Unit) in Constant (Unit) - | Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in App { operator = Tuple; arguments = map s_expr (s_nsepseq tuple)} + | Tuple {value=(l,tuple,r); region} -> let () = ignore (l,r,region) in s_tuple_expr (tuple |> s_nsepseq |> map s_expr) | List list -> s_list list | EmptyList empty_list -> s_empty_list empty_list | Set set -> s_set set @@ -278,6 +281,9 @@ and s_expr : I.expr -> O.expr = | MapLookUp map_lookup -> s_map_lookup map_lookup | ParExpr {value=(lpar,expr,rpar); region} -> let () = ignore (lpar,rpar,region) in s_expr expr +and s_tuple_expr tuple : O.expr = + Record (mapi (fun i e -> name_and_region_of_int i, e) tuple) + and s_map_lookup I.{value = {map_name; selector; index}; region} : O.expr = let {value = lbracket, index_expr, rbracket; region=region2} = index in let () = ignore (selector, lbracket, rbracket, region2, region) in @@ -288,7 +294,7 @@ and s_some_app {value=(c_Some, {value=(l,arguments,r); region=region2}); region} match s_nsepseq arguments with [] -> failwith "tuple cannot be empty" | [a] -> s_expr a - | l -> App { operator = Tuple; arguments = map s_expr l } + | l -> s_tuple_expr (map s_expr l) and s_list {value=(l, list, r); region} : O.expr = let () = ignore (l, r, region) in @@ -470,7 +476,7 @@ and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = match map s_expr (s_nsepseq sequence) with [] -> [Constant Unit] | [single_argument] -> [single_argument] - | args -> [App { operator = Tuple; arguments = args }] ; + | args -> [s_tuple_expr args] ; and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in From 51ee2cd63fa5456e465fdc63be54b9332b62c3c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:31:59 +0100 Subject: [PATCH 23/38] Added stub (failwith) for type annotator --- ParserMain.ml | 8 +++++--- Typecheck2.ml | 5 ++++- Typecheck2.mli | 4 +++- 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/ParserMain.ml b/ParserMain.ml index d6bff2efc..2c2fe2791 100644 --- a/ParserMain.ml +++ b/ParserMain.ml @@ -106,6 +106,8 @@ let () = (* Temporary: force dune to build AST2.ml *) let () = - let open Typecheck2 in - let _ = temporary_force_dune in - () + if false then + let _ = Typecheck2.annotate in + () + else + () diff --git a/Typecheck2.ml b/Typecheck2.ml index 726775164..8fdcd5770 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -2,6 +2,8 @@ module SMap = Map.Make(String) +module I = AST2.O + module O = struct type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) @@ -102,4 +104,5 @@ module O = struct } end -let temporary_force_dune = 123 +let annotate : I.ast -> O.ast = + failwith "type annotator is not implemented yet" diff --git a/Typecheck2.mli b/Typecheck2.mli index 6da40fa1e..b17e9016a 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -2,6 +2,8 @@ module SMap : Map.S with type key = string +module I = AST2.O + module O : sig type asttodo = [`TODO] (* occurrences of asttodo will point to some part of the original parser AST *) @@ -102,4 +104,4 @@ module O : sig } end -val temporary_force_dune : int +val annotate : I.ast -> O.ast From 8200bff78372eafef1518859e4a48e953842efc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:42:21 +0100 Subject: [PATCH 24/38] Temporary `TODO in place of regions --- AST2.ml | 18 +++++++++--------- Typecheck2.ml | 2 +- Typecheck2.mli | 2 +- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/AST2.ml b/AST2.ml index 7b99dad71..f8340a431 100644 --- a/AST2.ml +++ b/AST2.ml @@ -48,9 +48,9 @@ module O = struct and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } - type typed_var = { name:var_name; ty:type_expr } + type typed_var = { name:var_name; ty:type_expr; orig: asttodo } - type type_decl = { name:type_name; ty:type_expr } + type type_decl = { name:type_name; ty:type_expr; orig: asttodo } type expr = App of { operator: operator; arguments: expr list } @@ -205,15 +205,15 @@ and s_type_expr (orig : I.type_expr) : O.type_expr = match orig with 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 let ty = s_type_expr type_expr in - O.{ name = s_name name; ty = { ty with name = Some (s_name name) } } + O.{ name = s_name name; ty = { ty with name = Some (s_name name) }; orig = `TODO } let s_storage_decl I.{value={kwd_storage; name; colon; store_type; terminator}; region} : O.typed_var = let () = ignore (kwd_storage,colon,terminator,region) in - O.{ name = s_name name; ty = s_type_expr store_type } + O.{ name = s_name name; ty = s_type_expr store_type; orig = `TODO } let s_operations_decl I.{value={kwd_operations;name;colon;op_type;terminator}; region} : O.typed_var = let () = ignore (kwd_operations,colon,terminator,region) in - O.{ name = s_name name; ty = s_type_expr op_type } + O.{ name = s_name name; ty = s_type_expr op_type; orig = `TODO } let s_empty_list {value=(l, (lbracket, rbracket, colon, type_expr), r); region} : O.expr = let () = ignore (l, lbracket, rbracket, colon, r, region) in @@ -504,13 +504,13 @@ and gensym = fun ty -> i := !i + 1; (* TODO: Region.ghost *) - ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty} : O.typed_var) + ({name = {name=(string_of_int !i) ^ "gensym"; orig = Region.ghost}; ty; orig = `TODO} : O.typed_var) 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 let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; @@ -529,7 +529,7 @@ and s_proc_decl I.{value={kwd_procedure;name;param;kwd_is;local_decls;block;term let () = ignore (kwd_procedure,kwd_is,terminator,region) in let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; @@ -548,7 +548,7 @@ and s_entry_decl I.{value={kwd_entrypoint;name;param;kwd_is;local_decls;block;te let () = ignore (kwd_entrypoint,kwd_is,terminator,region) in let tuple_type = s_parameters param |> parameters_to_tuple in let single_argument = gensym tuple_type in - let ({name = single_argument_xxx; ty = _} : O.typed_var) = single_argument in + let ({name = single_argument_xxx; ty = _; orig = `TODO} : O.typed_var) = single_argument in O.{ name = s_name name; ty = type_expr region (Function { arg = tuple_type; diff --git a/Typecheck2.ml b/Typecheck2.ml index 8fdcd5770..b7955efff 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -44,7 +44,7 @@ module O = struct | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } diff --git a/Typecheck2.mli b/Typecheck2.mli index b17e9016a..4ab935302 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -44,7 +44,7 @@ module O : sig | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: AST.type_expr } + and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } From ea0198388ee25d9f664b317bb9e8b9ac93f3ccb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:45:22 +0100 Subject: [PATCH 25/38] Humour (bis) --- AST2.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/AST2.ml b/AST2.ml index f8340a431..9b260c5e0 100644 --- a/AST2.ml +++ b/AST2.ml @@ -70,7 +70,7 @@ module O = struct and operator = Function of var_name - | Construcor of var_name + | Constructor of var_name | UpdateField of field_name | GetField of field_name | Or | And | Lt | Leq | Gt | Geq | Equal | Neq | Cat | Cons | Add | Sub | Mult | Div | Mod From 3bf5ad28194d0dac2520062dca2c58a5efa51c40 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:45:38 +0100 Subject: [PATCH 26/38] Reformatted constant in AST2 to match that of Typecheck2 --- AST2.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/AST2.ml b/AST2.ml index 9b260c5e0..0760671f0 100644 --- a/AST2.ml +++ b/AST2.ml @@ -79,8 +79,12 @@ module O = struct | MapLookup and constant = - Unit | Int of Z.t | String of string | Bytes of MBytes.t | False | True - | Null of type_expr | EmptySet of type_expr | CNone of type_expr + Unit + | Int of Z.t | String of string | Bytes of MBytes.t + | False | True + | Null of type_expr + | EmptySet of type_expr + | CNone of type_expr and instr = Assignment of { name: var_name; value: expr } From 76d4e1bb8762cd237898908a69c87c8704b853de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 18:54:36 +0100 Subject: [PATCH 27/38] Distinguish function application from constructor application --- AST2.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/AST2.ml b/AST2.ml index 0760671f0..e66f7591c 100644 --- a/AST2.ml +++ b/AST2.ml @@ -468,7 +468,13 @@ and s_loop : I.loop -> O.instr list = function 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 } + let {value=fun_name_string;_} = fun_name in + let firstchar = String.sub fun_name_string 0 1 in + (* If it starts with a capital letter, then it is a constructor *) + if String.equal firstchar (String.uppercase_ascii firstchar) then + App { operator = Constructor (s_name fun_name); arguments = s_arguments arguments } + else + App { operator = Function (s_name fun_name); arguments = s_arguments arguments } and s_constr_app {value=(constr, arguments); region} : O.expr = let () = ignore (region) in From 90e894f9f41f1db00b2973467668879027758e65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 19:02:41 +0100 Subject: [PATCH 28/38] Add missing regions --- AST2.ml | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/AST2.ml b/AST2.ml index e66f7591c..9c0dcbc7c 100644 --- a/AST2.ml +++ b/AST2.ml @@ -87,18 +87,19 @@ module O = struct | CNone of type_expr and instr = - 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 } - | ProcedureCall of expr (* expr returns unit, drop the result. *) - | Fail of { expr: expr } + Assignment of { name: var_name; value: expr; orig: asttodo } + | While of { condition: expr; body: instr list; orig: asttodo } + | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } + | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } + | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } + | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) + | Fail of { expr: expr; orig: asttodo } type ast = { types : type_decl list; storage_decl : typed_var; declarations : decl list; + orig : I.t } end @@ -404,20 +405,20 @@ and s_instruction : I.instruction -> O.instr list = function 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 } + If { condition = s_expr test; ifso = s_instruction ifso; ifnot = s_instruction ifnot; orig = `TODO } 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) } + Match { expr = s_expr expr; cases = map s_case (s_nsepseq cases); orig = `TODO } 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 } + Assignment { name = s_name variable; value = s_expr expr; orig = `TODO } 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}] + [While {condition = s_expr expr; body = s_block block; orig = `TODO}] and s_for_loop : I.for_loop -> O.instr list = function ForInt for_int -> s_for_int for_int @@ -431,15 +432,17 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo | None -> O.Lt, O.Add in let step = s_step step in [ - Assignment { name; value = s_expr expr }; + Assignment { name; value = s_expr expr; orig = `TODO }; (* TODO: lift the declaration of the variable, to avoid creating a nested scope here. *) While { condition = App { operator = condition; - arguments = [Var name; s_expr bound] }; + arguments = [Var name; s_expr bound]}; body = append (s_block block) [O.Assignment { name; value = App { operator; - arguments = [Var name; step]}}] + arguments = [Var name; step]}; + orig = `TODO }]; + orig = `TODO } ] @@ -450,7 +453,8 @@ and s_for_collect ({value={kwd_for;var;bind_to;kwd_in;expr;block}; _} : I.for_co list = s_expr expr; key = s_name var; value = s_bind_to bind_to; - body = s_block block + body = s_block block; + orig = `TODO } ] @@ -490,7 +494,7 @@ and s_arguments {value=(lpar, sequence, rpar); region} : O.expr list = and s_fail ((kwd_fail, expr) : (I.kwd_fail * I.expr)) : O.instr = let () = ignore (kwd_fail) in - Fail { expr = s_expr expr } + Fail { expr = s_expr expr; orig = `TODO } @@ -500,7 +504,7 @@ and s_single_instr : I.single_instr -> O.instr list = function | Match {value; _} -> [s_match_instr value] | Ass instr -> [s_ass_instr instr] | Loop loop -> s_loop loop -| ProcCall fun_call -> [ProcedureCall (s_fun_call fun_call)] +| ProcCall fun_call -> [ProcedureCall { expr = s_fun_call fun_call; orig = `TODO }] | Null kwd_null -> let () = ignore (kwd_null) in [] | Fail {value; _} -> [s_fail value] @@ -609,7 +613,7 @@ let s_ast (ast : I.ast) : O.ast = let () = match operations_decl with Some _ -> failwith "Operations declaration is not allowed anymore TODO" | None -> () - in {types; storage_decl; declarations} + in {types; storage_decl; declarations; orig = ast} From 689673ccfaec6decc308ff6a082504bc3e279d70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 19:14:10 +0100 Subject: [PATCH 29/38] Single variable for ForCollect, set k=>v aside for now. --- AST2.ml | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/AST2.ml b/AST2.ml index 9c0dcbc7c..0e6830928 100644 --- a/AST2.ml +++ b/AST2.ml @@ -89,7 +89,7 @@ module O = struct and instr = Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } - | ForCollection of { list: expr; key: var_name; value: var_name option; body: instr list; orig: asttodo } + | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) @@ -448,15 +448,18 @@ and s_for_int ({value={kwd_for;ass;down;kwd_to;bound;step;block}; region} : I.fo 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; - orig = `TODO - } - ] + let for_instr = + match s_bind_to bind_to with + Some _ -> + failwith "TODO: For on maps is not supported yet!" + | None -> + O.ForCollection { + list = s_expr expr; + var = s_name var; + body = s_block block; + orig = `TODO + } + in [for_instr] and s_step : (I.kwd_step * I.expr) option -> O.expr = function Some (kwd_step, expr) -> let () = ignore (kwd_step) in s_expr expr From adec2bb5e0d43ca17f5cd98714b1b92b8f26388e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 19:23:37 +0100 Subject: [PATCH 30/38] Cleanup --- AST2.ml | 2 +- Typecheck2.ml | 2 +- Typecheck2.mli | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/AST2.ml b/AST2.ml index 0e6830928..55c268c53 100644 --- a/AST2.ml +++ b/AST2.ml @@ -99,7 +99,7 @@ module O = struct types : type_decl list; storage_decl : typed_var; declarations : decl list; - orig : I.t + orig : AST.t } end diff --git a/Typecheck2.ml b/Typecheck2.ml index b7955efff..96fa3cdc7 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -100,7 +100,7 @@ module O = struct types : type_decl list; storage_decl : typed_var; declarations : decl list; - orig: AST.t + orig : AST.t } end diff --git a/Typecheck2.mli b/Typecheck2.mli index 4ab935302..0ae31d31b 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -100,7 +100,7 @@ module O : sig types : type_decl list; storage_decl : typed_var; declarations : decl list; - orig: AST.t + orig : AST.t } end From 8fc1729f47aa68868fdc85950484dfa5616d8155 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 19:30:55 +0100 Subject: [PATCH 31/38] If simplified to match --- AST2.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/AST2.ml b/AST2.ml index 55c268c53..86381a293 100644 --- a/AST2.ml +++ b/AST2.ml @@ -405,7 +405,14 @@ and s_instruction : I.instruction -> O.instr list = function 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; orig = `TODO } + let test = s_expr test in + let ifso = O.PTrue, s_instruction ifso in + let ifnot = O.PFalse, s_instruction ifnot in + Match { + expr = test; + cases = [ifso; ifnot]; + orig = `TODO + } and s_match_instr I.{kwd_match;expr;kwd_with;lead_vbar;cases;kwd_end} : O.instr = let {value=cases;region} = cases in From 7a84cf1c8bbe9eecdcefd0f1db6b507bb5ab638f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 19:32:36 +0100 Subject: [PATCH 32/38] Removed If (missing in previous commit) --- AST2.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/AST2.ml b/AST2.ml index 86381a293..231257b2a 100644 --- a/AST2.ml +++ b/AST2.ml @@ -90,7 +90,6 @@ module O = struct Assignment of { name: var_name; value: expr; orig: asttodo } | While of { condition: expr; body: instr list; orig: asttodo } | ForCollection of { list: expr; var: var_name; body: instr list; orig: asttodo } - | If of { condition: expr; ifso: instr list; ifnot: instr list; orig: asttodo } | Match of { expr: expr; cases: (pattern * instr list) list; orig: asttodo } | ProcedureCall of { expr: expr; orig: asttodo } (* expr returns unit, drop the result. Similar to OCaml's ";". *) | Fail of { expr: expr; orig: asttodo } From fb97b056ca4a5a848ddce663bce65637a8347dd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 20:00:01 +0100 Subject: [PATCH 33/38] Started structure for the type annotator --- Typecheck2.ml | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 96fa3cdc7..565610542 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -104,5 +104,26 @@ module O = struct } end -let annotate : I.ast -> O.ast = - failwith "type annotator is not implemented yet" +type te = O.type_expr list SMap.t +type ve = O.type_expr list SMap.t +type tve = te * ve + +let a_types : tve -> I.type_decl list -> tve * O.type_decl list = + failwith "TODO" + +let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var = + failwith "TODO" + +let a_declarations : tve -> I.decl list -> tve * O.decl list = + failwith "TODO" + +let a_ast I.{types; storage_decl; declarations; orig} = + let tve = SMap.empty, SMap.empty in + let tve, types = a_types tve types in + let tve, storage_decl = a_storage_decl tve storage_decl in + let tve, declarations = a_declarations tve declarations in + let _ = tve in + O.{types; storage_decl; declarations; orig} + +let annotate : I.ast -> O.ast = a_ast + From 8830f598dff6050e09475ebb1c7f9f97d74bff6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 20:09:06 +0100 Subject: [PATCH 34/38] skeleton for a_types --- Typecheck2.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index 565610542..0c84ebe8f 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -108,9 +108,19 @@ type te = O.type_expr list SMap.t type ve = O.type_expr list SMap.t type tve = te * ve -let a_types : tve -> I.type_decl list -> tve * O.type_decl list = +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 a_type (tve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl = failwith "TODO" +let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list = + fold_map a_type tve l + let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var = failwith "TODO" From 0943408463f52f17d23896e1a8473de65a318078 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 20:42:41 +0100 Subject: [PATCH 35/38] SMap.t for records and sums --- AST2.ml | 23 ++++++++++++++++------- Typecheck2.ml | 29 ++++++++++++++++++++++++++--- Typecheck2.mli | 6 +++--- 3 files changed, 45 insertions(+), 13 deletions(-) diff --git a/AST2.ml b/AST2.ml index 231257b2a..b71c7f472 100644 --- a/AST2.ml +++ b/AST2.ml @@ -27,7 +27,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of (field_name * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -36,8 +36,8 @@ module O = struct | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of (field_name * type_expr) list + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -156,17 +156,26 @@ let s_type_constructor {value=name;region} : O.type_constructor = (* TODO: escape the name, prevent any \x1b and other weird characters from appearing in the output *) | _ -> failwith ("Unknown type constructor: " ^ name) +let named_list_to_map (l : (O.name_and_region * 'a) list) : (O.name_and_region * 'a) SMap.t = + List.fold_left + (fun m ((x,_) as p) -> + let {name;_} : O.name_and_region = x in + SMap.add name p m) + SMap.empty + l + let rec s_cartesian {value=sequence; region} : O.type_expr = let () = ignore (region) in s_nsepseq sequence |>map s_type_expr |> mapi (fun i p -> name_and_region_of_int i, p) + |> named_list_to_map |> (fun x -> (Record x : O.type_expr_case)) |> type_expr region and s_sum_type {value=sequence; region} : O.type_expr = let () = ignore (region) in - type_expr region (Sum (map s_variant (s_nsepseq sequence))) + type_expr region (Sum (map s_variant (s_nsepseq sequence) |> named_list_to_map)) and s_variant {value=(constr, kwd_of, cartesian); region} = let () = ignore (kwd_of,region) in @@ -174,7 +183,7 @@ and s_variant {value=(constr, kwd_of, cartesian); region} = and s_record_type {value=(kwd_record, field_decls, kwd_end); region} : O.type_expr = let () = ignore (kwd_record,region,kwd_end) in - type_expr region (Record (map s_field_decl (s_nsepseq field_decls)) : O.type_expr_case) + type_expr region (Record (map s_field_decl (s_nsepseq field_decls) |> named_list_to_map) : O.type_expr_case) and s_field_decl {value=(var, colon, type_expr); region} : O.type_name * O.type_expr = let () = ignore (colon,region) in @@ -234,7 +243,7 @@ let s_none {value=(l, (c_None, colon, type_expr), r); region} : O.expr = let parameters_to_tuple (parameters : (string * O.type_expr) list) : O.type_expr = (* TODO: use records with named fields to have named arguments. *) let parameter_tuple : O.type_expr_case = - Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters) in + Record (mapi (fun i (_name,ty) -> name_and_region_of_int i, ty) parameters |> named_list_to_map) in O.{ type_expr = parameter_tuple; name = None; orig = Region.ghost } and parameters_to_decls singleparam (parameters : (string * O.type_expr) list) : O.decl list = @@ -354,7 +363,7 @@ and s_ptuple {value=(lpar, sequence, rpar); region} = s_nsepseq sequence |> map s_core_pattern |> mapi (fun i p -> name_and_region_of_int i, p) - |> fun x -> O.PRecord x + |> fun x -> O.PRecord (x |> named_list_to_map) and s_psome {value=(c_Some,{value=(l,psome,r);region=region2});region} : O.pattern = let () = ignore (c_Some,l,r,region2,region) in diff --git a/Typecheck2.ml b/Typecheck2.ml index 0c84ebe8f..d748a23e9 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -1,3 +1,5 @@ +[@@@warning "-27"] (* TODO *) +[@@@warning "-32"] (* TODO *) [@@@warning "-30"] module SMap = Map.Make(String) @@ -25,7 +27,7 @@ module O = struct | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of (field_name * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -34,8 +36,8 @@ module O = struct | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of (field_name * type_expr) list + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr @@ -115,6 +117,27 @@ let fold_map f a l = let last_acc, last_l = List.fold_left f (a, []) l in last_acc, List.rev last_l +let a_type_constructor (tve : tve) : I.type_constructor -> O.type_constructor = function + Option -> failwith "TODO" +| List -> failwith "TODO" +| Set -> failwith "TODO" +| Map -> failwith "TODO" + +let a_type_expr_case (tve : tve) : I.type_expr_case -> O.type_expr_case = function + Sum l -> failwith "TODO" + | Record l -> failwith "TODO" + | TypeApp (tc, args) -> failwith "TODO" + | Function {arg;ret} -> failwith "TODO" + | Ref t -> failwith "TODO" + | String -> failwith "TODO" + | Int -> failwith "TODO" + | Unit -> failwith "TODO" + | Bool -> failwith "TODO" + + +let a_type_expr (tve : tve) ({type_expr;name;orig} : I.type_expr) : O.type_expr = + failwith "TODO" + let a_type (tve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl = failwith "TODO" diff --git a/Typecheck2.mli b/Typecheck2.mli index 0ae31d31b..26a1011c9 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -25,7 +25,7 @@ module O : sig | PSome of pattern | PCons of pattern * pattern | PNull - | PRecord of (field_name * pattern) list + | PRecord of (field_name * pattern) SMap.t type type_constructor = Option @@ -34,8 +34,8 @@ module O : sig | Map type type_expr_case = - Sum of (type_name * type_expr) list - | Record of (field_name * type_expr) list + Sum of (type_name * type_expr) SMap.t + | Record of (field_name * type_expr) SMap.t | TypeApp of type_constructor * (type_expr list) | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr From bac4ce10247f6f3b839855294714feb9f9c123c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 21:14:05 +0100 Subject: [PATCH 36/38] More type annotator skeleton --- Typecheck2.ml | 47 +++++++++++++++++++++++++++++++---------------- Typecheck2.mli | 4 ++-- 2 files changed, 33 insertions(+), 18 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index d748a23e9..e92d05f6b 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -46,11 +46,11 @@ module O = struct | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } + and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } - type type_decl = { name:string; ty:type_expr; orig: asttodo } + type type_decl = { name: type_name; ty:type_expr; orig: asttodo } type expr_case = App of { operator: operator; arguments: expr list } @@ -117,29 +117,44 @@ let fold_map f a l = let last_acc, last_l = List.fold_left f (a, []) l in last_acc, List.rev last_l +let shadow (name : string) (typ : O.type_expr) (env : O.type_expr list SMap.t) + : O.type_expr list SMap.t = + SMap.update name (function None -> Some [typ] | Some tl -> Some (typ :: tl)) env + +let string_of_name ({name;_} : I.name_and_region) = name + +let a_name_and_region ({name; orig} : I.name_and_region) : O.name_and_region = + {name; orig} + let a_type_constructor (tve : tve) : I.type_constructor -> O.type_constructor = function - Option -> failwith "TODO" -| List -> failwith "TODO" -| Set -> failwith "TODO" -| Map -> failwith "TODO" + Option -> Option +| List -> List +| Set -> Set +| Map -> Map let a_type_expr_case (tve : tve) : I.type_expr_case -> O.type_expr_case = function - Sum l -> failwith "TODO" - | Record l -> failwith "TODO" + Sum lt -> failwith "TODO" + | Record lt -> failwith "TODO" | TypeApp (tc, args) -> failwith "TODO" | Function {arg;ret} -> failwith "TODO" | Ref t -> failwith "TODO" - | String -> failwith "TODO" - | Int -> failwith "TODO" - | Unit -> failwith "TODO" - | Bool -> failwith "TODO" - + | String -> String + | Int -> Int + | Unit -> Unit + | Bool -> Bool let a_type_expr (tve : tve) ({type_expr;name;orig} : I.type_expr) : O.type_expr = - failwith "TODO" + let type_expr = a_type_expr_case tve type_expr in + let name = match name with + None -> None + |Some name -> Some (a_name_and_region name) + in {type_expr;name;orig} -let a_type (tve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl = - failwith "TODO" +let a_type (te,ve : tve) ({name;ty;orig} : I.type_decl) : tve * O.type_decl = + let ty = a_type_expr (te,ve) ty in + let tve = shadow (string_of_name name) ty te, ve in + let name = (a_name_and_region name) in + tve, {name; ty; orig} let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list = fold_map a_type tve l diff --git a/Typecheck2.mli b/Typecheck2.mli index 26a1011c9..370badbf0 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -44,11 +44,11 @@ module O : sig | Unit | Bool - and type_expr = { type_expr: type_expr_case; name: string option; orig: Region.t } + and type_expr = { type_expr: type_expr_case; name: type_name option; orig: Region.t } type typed_var = { name:var_name; ty:type_expr; orig: asttodo } - type type_decl = { name:string; ty:type_expr; orig: asttodo } + type type_decl = { name:type_name; ty:type_expr; orig: asttodo } type expr_case = App of { operator: operator; arguments: expr list } From 63be1b9b7d62802623cbbb26ca6ce7d5d5805a4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 22:11:27 +0100 Subject: [PATCH 37/38] More of the type annotator structure --- Typecheck2.ml | 54 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/Typecheck2.ml b/Typecheck2.ml index e92d05f6b..d5f6b6016 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -121,6 +121,11 @@ let shadow (name : string) (typ : O.type_expr) (env : O.type_expr list SMap.t) : O.type_expr list SMap.t = SMap.update name (function None -> Some [typ] | Some tl -> Some (typ :: tl)) env +let lookup (name : string) (env : O.type_expr list SMap.t) : O.type_expr = + match SMap.find name env with + latest :: shadowed -> latest + | [] -> failwith "Unbound variable" + let string_of_name ({name;_} : I.name_and_region) = name let a_name_and_region ({name; orig} : I.name_and_region) : O.name_and_region = @@ -162,8 +167,53 @@ let a_types (tve : tve) (l : I.type_decl list) : tve * O.type_decl list = let a_storage_decl : tve -> I.typed_var -> tve * O.typed_var = failwith "TODO" -let a_declarations : tve -> I.decl list -> tve * O.decl list = - failwith "TODO" +let type_expr_case_equal (t1 : O.type_expr_case) (t2 : O.type_expr_case) : bool = match t1,t2 with + Sum m1, Sum m2 -> failwith "TODO" (* of (O.name_and_region * O.type_expr) SMap.t *) + | Record m1, Record m2 -> failwith "TODO" (* of (O.name_and_region * O.type_expr) SMap.t *) + | TypeApp (tc1, args1), TypeApp (tc2, args2) -> failwith "TODO" (* of O.type_constructor * O.type_expr list *) + | Function {arg=arg1;ret=ret1}, Function {arg=arg2;ret=ret2} -> failwith "TODO" (* of { arg : O.type_expr; ret : O.type_expr; } *) + | Ref t1, Ref t2 -> failwith "TODO" (* of O.type_expr *) + | String, String -> true + | Int, Int -> true + | Unit, Unit -> true + | Bool, Bool -> true + | _ -> false + +let type_expr_equal (t1 : O.type_expr) (t2 : O.type_expr) : bool = + type_expr_case_equal t1.type_expr t2.type_expr + +let check_type_expr_equal (expected : O.type_expr) (actual : O.type_expr) : unit = + if type_expr_equal expected actual then + () + else + failwith "got [actual] but expected [expected]" + +let a_var_expr (te,ve : tve) (expected : O.type_expr) (var_name : I.name_and_region) : O.expr_case = + check_type_expr_equal expected (lookup (string_of_name var_name) ve); + Var { name = a_name_and_region var_name; + ty = expected; + orig = `TODO } + +let a_expr_case (te,ve : tve) (expected : O.type_expr) : I.expr -> O.expr_case = function + App {operator;arguments} -> failwith "TODO" + | Var var_name -> a_var_expr (te,ve) expected var_name + | Constant constant -> failwith "TODO" + | Record record -> failwith "TODO" + | Lambda lambda -> failwith "TODO" + +let a_expr (te,ve : tve) (expected : O.type_expr) (e : I.expr) : O.expr = + let expr_case = a_expr_case (te,ve) expected e in + { expr = expr_case; ty = expected; orig = `TODO } + +let a_declaration (te,ve : tve) ({name;ty;value} : I.decl) : tve * O.decl = + let ty = a_type_expr (te,ve) ty in + let value = a_expr (te,ve) ty value in + let ve = shadow (string_of_name name) ty ve in + let name = a_name_and_region name in + (te,ve), {var={name;ty;orig=`TODO};value;orig = `TODO} + +let a_declarations (tve : tve) (l : I.decl list) : tve * O.decl list = + fold_map a_declaration tve l let a_ast I.{types; storage_decl; declarations; orig} = let tve = SMap.empty, SMap.empty in From acf1706d3d95f01e982308fe533e28b72f63c7ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 14 Mar 2019 22:42:40 +0100 Subject: [PATCH 38/38] more typechecker structure --- AST2.ml | 1 + Typecheck2.ml | 54 +++++++++++++++++++++++++++++++++++++++++++++++--- Typecheck2.mli | 1 + 3 files changed, 53 insertions(+), 3 deletions(-) diff --git a/AST2.ml b/AST2.ml index b71c7f472..78a181f79 100644 --- a/AST2.ml +++ b/AST2.ml @@ -42,6 +42,7 @@ module O = struct | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr | String + | Bytes | Int | Unit | Bool diff --git a/Typecheck2.ml b/Typecheck2.ml index d5f6b6016..1bd6fee69 100644 --- a/Typecheck2.ml +++ b/Typecheck2.ml @@ -42,6 +42,7 @@ module O = struct | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr | String + | Bytes | Int | Unit | Bool @@ -117,6 +118,8 @@ let fold_map f a l = let last_acc, last_l = List.fold_left f (a, []) l in last_acc, List.rev last_l +let map f l = List.rev (List.rev_map f l) + let shadow (name : string) (typ : O.type_expr) (env : O.type_expr list SMap.t) : O.type_expr list SMap.t = SMap.update name (function None -> Some [typ] | Some tl -> Some (typ :: tl)) env @@ -194,11 +197,56 @@ let a_var_expr (te,ve : tve) (expected : O.type_expr) (var_name : I.name_and_reg ty = expected; orig = `TODO } +let a_constant_expr (tve : tve) (expected : O.type_expr) (constant : I.constant) : O.expr_case = + let to_type_expr type_expr_case : O.type_expr = + { type_expr = type_expr_case; name = None; orig = Region.ghost } in + let actual : O.type_expr = match constant with + Unit -> to_type_expr Unit + | Int _ -> to_type_expr Int + | String _ -> to_type_expr String + | Bytes _ -> to_type_expr Bytes + | False -> to_type_expr Bool + | True -> to_type_expr Bool + | Null t -> a_type_expr tve t + | EmptySet t -> a_type_expr tve t + | CNone t -> a_type_expr tve t + in + check_type_expr_equal expected actual; + let c : O.constant = match constant with + Unit -> Unit + | Int i -> Int i + | String s -> String s + | Bytes b -> Bytes b + | False -> False + | True -> True + | Null _ -> Null + | EmptySet _ -> EmptySet + | CNone _ -> CNone + in Constant c + +let map_to_list m = + List.rev (SMap.fold (fun field_name_string p l -> p :: l) m []) + +let a_field tve (expected,expr) = + failwith "TODO" + +let a_record (tve : tve) (expected : O.type_expr) (record : (I.field_name * I.expr) list) + : O.expr_case = + let {type_expr = expected; _} : O.type_expr = expected in + let expected = match expected with + Record fields -> fields + | _ -> failwith "expected some_type but got record" in + let expected_and_field = + List.combine + (map_to_list expected) + record (* TODO SHOULD BE (map_to_list record) *) in + Record (map (a_field tve) expected_and_field) + let a_expr_case (te,ve : tve) (expected : O.type_expr) : I.expr -> O.expr_case = function App {operator;arguments} -> failwith "TODO" - | Var var_name -> a_var_expr (te,ve) expected var_name - | Constant constant -> failwith "TODO" - | Record record -> failwith "TODO" + | Var var_name -> a_var_expr (te,ve) expected var_name + | Constant constant -> a_constant_expr (te,ve) expected constant + | Record record -> a_record (te,ve) expected record | Lambda lambda -> failwith "TODO" let a_expr (te,ve : tve) (expected : O.type_expr) (e : I.expr) : O.expr = diff --git a/Typecheck2.mli b/Typecheck2.mli index 370badbf0..e73f6a875 100644 --- a/Typecheck2.mli +++ b/Typecheck2.mli @@ -40,6 +40,7 @@ module O : sig | Function of { arg: type_expr; ret: type_expr } | Ref of type_expr | String + | Bytes | Int | Unit | Bool