diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 8681301a7..903873eb5 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -63,12 +63,14 @@ test:
- /^.*-run-dev$/
script:
- nix-build nix -A ligo-coverage
+ - cat result/share/coverage-all
- cp -Lr --no-preserve=mode,ownership,timestamps result/share/coverage .
artifacts:
paths:
- coverage
-webide-e2e:
+# Strange race conditions, disable for now
+.webide-e2e:
extends: .nix
only:
- merge_requests
diff --git a/gitlab-pages/docs/language-basics/maps-records.md b/gitlab-pages/docs/language-basics/maps-records.md
index 5c27f1395..81a26f1be 100644
--- a/gitlab-pages/docs/language-basics/maps-records.md
+++ b/gitlab-pages/docs/language-basics/maps-records.md
@@ -5,12 +5,12 @@ title: Records and Maps
import Syntax from '@theme/Syntax';
-So far we have seen pretty basic data types. LIGO also offers more
+So far, we have seen pretty basic data types. LIGO also offers more
complex built-in constructs, such as *records* and *maps*.
## Records
-Records are one way data of different types can be packed into a
+Records are one-way data of different types can be packed into a
single type. A record is made of a set of *fields*, which are made of
a *field name* and a *field type*. Given a value of a record type, the
value bound to a field can be accessed by giving its field name to a
@@ -18,8 +18,6 @@ special operator (`.`).
Let us first consider and example of record type declaration.
-
-
```pascaligo group=records1
@@ -55,10 +53,8 @@ type user = {
-
And here is how a record value is defined:
-
```pascaligo group=records1
@@ -142,7 +138,7 @@ points on a plane.
In PascaLIGO, the shape of that expression is
` with `.
-The record variable is the record to update and the
+The record variable is the record to update, and the
record value is the update itself.
```pascaligo group=records2
@@ -160,13 +156,13 @@ following command of the shell:
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.ligo
-translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])"
+xy_translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])"
# Outputs: {z = 1 , y = 7 , x = 5}
```
You have to understand that `p` has not been changed by the functional
-update: a namless new version of it has been created and returned by
-the blockless function.
+update: a nameless new version of it has been created and returned by
+the block-less function.
@@ -186,6 +182,7 @@ let xy_translate (p, vec : point * vector) : point =
You can call the function `xy_translate` defined above by running the
following command of the shell:
+
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.mligo
@@ -218,6 +215,7 @@ let xy_translate = ((p, vec) : (point, vector)) : point =>
You can call the function `xy_translate` defined above by running the
following command of the shell:
+
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.religo
@@ -326,12 +324,21 @@ let change_color_preference = (account : account, color : color): account =>
Note that all the records in the path will get updated. In this example that's
`account` and `preferences`.
+You can call the function `change_color_preference` defined above by running the
+following command:
+
+```shell
+ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_nested_update.ligo
+change_color_preference "(record [id=1001; preferences=record [color=Blue; other=1]], Green)"
+# Outputs: record[id -> 1001 , preferences -> record[color -> Green(unit) , other -> 1]]
+```
+
### Record Patches
Another way to understand what it means to update a record value is to
-make sure that any further reference to the value afterwards will
+make sure that any further reference to the value afterward will
exhibit the modification. This is called a `patch` and this is only
possible in PascaLIGO, because a patch is an *instruction*, therefore
we can only use it in a block. Similarly to a *functional update*, a
@@ -355,6 +362,7 @@ function xy_translate (var p : point; const vec : vector) : point is
You can call the function `xy_translate` defined above by running the
following command of the shell:
+
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_patch.ligo
@@ -378,6 +386,7 @@ function xy_translate (var p : point; const vec : vector) : point is
You can call the new function `xy_translate` defined above by running the
following command of the shell:
+
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_patch2.ligo
@@ -401,6 +410,7 @@ function xy_translate (var p : point; const vec : vector) : point is
You can call the new function `xy_translate` defined above by running the
following command of the shell:
+
```shell
ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_simu.ligo
@@ -425,8 +435,6 @@ sense.
Here is how a custom map from addresses to a pair of integers is
defined.
-
-
```pascaligo group=maps
@@ -680,8 +688,8 @@ let assign = (m : register) : register =>
(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), Some ((4,9)), m);
```
-Notice the optional value `Some (4,9)` instead of `(4,9)`. If we had
-use `None` instead, that would have meant that the binding is removed.
+Notice the optional value `Some (4,9)` instead of `(4,9)`. If we used
+`None` instead that would have meant that the binding is removed.
As a particular case, we can only add a key and its associated value.
@@ -693,7 +701,6 @@ let add = (m : register) : register =>
-
To remove a binding from a map, we need its key.
@@ -748,8 +755,8 @@ There are three kinds of functional iterations over LIGO maps: the
The first, the *iterated operation*, is an iteration over the map with
no return value: its only use is to produce side-effects. This can be
-useful if for example you would like to check that each value inside
-of a map is within a certain range, and fail with an error otherwise.
+useful if, for example you would like to check that each value inside
+of a map is within a certain range and fail with an error otherwise.
The predefined functional iterator implementing the iterated operation
over maps is called `Map.iter`. In the following example, the register
@@ -985,7 +992,7 @@ let moves : register =
(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), (0,3))]
```
-The predefind function `Big_map.literal` constructs a big map from a
+The predefined function `Big_map.literal` constructs a big map from a
list of key-value pairs `(, )`. Note also the semicolon
separating individual map entries. The annotated value `("
value>" : address)` means that we cast a string into an address.
@@ -1000,7 +1007,7 @@ let moves : register =
("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address, (0,3))]);
```
-The predefind function `Big_map.literal` constructs a big map from a
+The predefined function `Big_map.literal` constructs a big map from a
list of key-value pairs `(, )`. Note also the semicolon
separating individual map entries. The annotated value `("
value>" : address)` means that we cast a string into an address.
diff --git a/nix/ocaml-overlay.nix b/nix/ocaml-overlay.nix
index b44cfdcef..8dd971e79 100644
--- a/nix/ocaml-overlay.nix
+++ b/nix/ocaml-overlay.nix
@@ -133,19 +133,16 @@ in {
echo "Coverage:"
BISECT_ENABLE=yes dune runtest --force
bisect-ppx-report html -o $out/share/coverage/all --title="LIGO overall test coverage"
- bisect-ppx-report summary --per-file
+ bisect-ppx-report summary --per-file > $out/share/coverage-all
echo "Test coverage:"
BISECT_ENABLE=yes dune runtest src/test --force
bisect-ppx-report html -o $out/share/coverage/ligo --title="LIGO test coverage"
- bisect-ppx-report summary --per-file
echo "Doc coverage:"
BISECT_ENABLE=yes dune build @doc-test --force
bisect-ppx-report html -o $out/share/coverage/docs --title="LIGO doc coverage"
- bisect-ppx-report summary --per-file
echo "CLI test coverage:"
BISECT_ENABLE=yes dune runtest src/bin/expect_tests
bisect-ppx-report html -o $out/share/coverage/cli --title="CLI test coverage"
- bisect-ppx-report summary --per-file
'';
installPhase = "true";
});
diff --git a/src/bin/cli.ml b/src/bin/cli.ml
index c8da92924..8c3720042 100644
--- a/src/bin/cli.ml
+++ b/src/bin/cli.ml
@@ -275,7 +275,7 @@ let compile_parameter =
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
- let env = Ast_typed.program_environment typed_prg in
+ let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
@@ -302,7 +302,7 @@ let interpret =
| Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
- let env = Ast_typed.program_environment typed_prg in
+ let env = Ast_typed.program_environment Environment.default typed_prg in
ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in
@@ -344,7 +344,7 @@ let compile_storage =
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
- let env = Ast_typed.program_environment typed_prg in
+ let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in
@@ -368,7 +368,7 @@ let dry_run =
let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in
- let env = Ast_typed.program_environment typed_prg in
+ let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) =
@@ -398,7 +398,7 @@ let run_function =
let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
- let env = Ast_typed.program_environment typed_prg in
+ let env = Ast_typed.program_environment Environment.default typed_prg in
let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in
diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml
index 6de7be144..c52e7c366 100644
--- a/src/bin/expect_tests/contract_tests.ml
+++ b/src/bin/expect_tests/contract_tests.ml
@@ -7,7 +7,7 @@ let bad_contract basename =
let%expect_test _ =
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
- [%expect {| 1700 bytes |}] ;
+ [%expect {| 1668 bytes |}] ;
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
[%expect {| 995 bytes |}] ;
@@ -276,7 +276,7 @@ let%expect_test _ =
DIG 7 ;
DUP ;
DUG 8 ;
- NONE (pair (address %card_owner) (nat %card_pattern)) ;
+ NONE (pair address nat) ;
SWAP ;
UPDATE ;
DIG 2 ;
diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml
index f1437f44f..b8a6cd90e 100644
--- a/src/bin/expect_tests/michelson_converter.ml
+++ b/src/bin/expect_tests/michelson_converter.ml
@@ -202,4 +202,121 @@ let%expect_test _ =
IF_LEFT
{ DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } }
{ DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } ;
+ DIP { DROP 2 } } } |}]
+
+let%expect_test _ =
+ run_ligo_good [ "compile-contract" ; (contract "double_fold_converter.religo") ; "main" ] ;
+ [%expect {|
+ { parameter
+ (list (pair (address %from_)
+ (list %txs (pair (address %to_) (pair (nat %token_id) (nat %amount)))))) ;
+ storage (big_map nat address) ;
+ code { DUP ;
+ CDR ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ CAR ;
+ ITER { SWAP ;
+ PAIR ;
+ DUP ;
+ CDR ;
+ DUP ;
+ CAR ;
+ SENDER ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ COMPARE ;
+ NEQ ;
+ IF { PUSH string "NOT_OWNER" ; FAILWITH } { PUSH unit Unit } ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ DIG 4 ;
+ DUP ;
+ DUG 5 ;
+ CAR ;
+ PAIR ;
+ DIG 3 ;
+ DUP ;
+ DUG 4 ;
+ CDR ;
+ ITER { SWAP ;
+ PAIR ;
+ DUP ;
+ CAR ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ CDR ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ CAR ;
+ DIG 2 ;
+ DUP ;
+ DUG 3 ;
+ CDR ;
+ DIG 2 ;
+ DUP ;
+ DUG 3 ;
+ CDR ;
+ CAR ;
+ DIG 3 ;
+ DUP ;
+ DUG 4 ;
+ CAR ;
+ DIG 4 ;
+ DUP ;
+ DUG 5 ;
+ CDR ;
+ CDR ;
+ PAIR ;
+ PAIR ;
+ DIG 2 ;
+ DUP ;
+ DUG 3 ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ CDR ;
+ GET ;
+ IF_NONE
+ { PUSH string "TOKEN_UNDEFINED" ; FAILWITH }
+ { DIG 2 ;
+ DUP ;
+ DUG 3 ;
+ DIG 1 ;
+ DUP ;
+ DUG 2 ;
+ COMPARE ;
+ EQ ;
+ IF { DUP } { PUSH string "INSUFFICIENT_BALANCE" ; FAILWITH } ;
+ DIP { DROP } } ;
+ DIG 2 ;
+ DUP ;
+ DUG 3 ;
+ DIG 4 ;
+ DUP ;
+ DUG 5 ;
+ DIG 3 ;
+ DUP ;
+ DUG 4 ;
+ CAR ;
+ CDR ;
+ SOME ;
+ DIG 4 ;
+ DUP ;
+ DUG 5 ;
+ CDR ;
+ UPDATE ;
+ PAIR ;
+ DIP { DROP 7 } } ;
+ DUP ;
+ CAR ;
+ DIP { DROP 5 } } ;
+ DUP ;
+ NIL operation ;
+ PAIR ;
DIP { DROP 2 } } } |}]
\ No newline at end of file
diff --git a/src/environment/bool.ml b/src/environment/bool.ml
index 611c84dfd..d3fea07eb 100644
--- a/src/environment/bool.ml
+++ b/src/environment/bool.ml
@@ -1,4 +1,8 @@
open Ast_typed
open Stage_common.Constant
-let environment = env_sum_type ~type_name:t_bool @@ [(Constructor "true",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});(Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1})]
+let environment = Ast_typed.Environment.add_ez_sum_type ~type_name:t_bool @@
+ [
+ (Constructor "true" ,{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});
+ (Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1});
+ ]
diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml
index 9e2019df5..0cb37196d 100644
--- a/src/main/compile/helpers.ml
+++ b/src/main/compile/helpers.ml
@@ -192,7 +192,7 @@ let pretty_print_pascaligo source =
let pretty_print_cameligo source =
let%bind ast = Parser.Cameligo.parse_file source in
- let doc = Parser_cameligo.Pretty.make ast in
+ let doc = Parser_cameligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
@@ -203,7 +203,7 @@ let pretty_print_cameligo source =
let pretty_print_reasonligo source =
let%bind ast = Parser.Reasonligo.parse_file source in
- let doc = Parser_reasonligo.Pretty.make ast in
+ let doc = Parser_reasonligo.Pretty.print ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml
index 9c054400e..7ef89b360 100644
--- a/src/passes/1-parser/cameligo.ml
+++ b/src/passes/1-parser/cameligo.ml
@@ -157,7 +157,7 @@ let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
- let doc = Pretty.make (fst ast) in
+ let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml
index 60b89c7c3..47462302d 100644
--- a/src/passes/1-parser/cameligo/ParserMain.ml
+++ b/src/passes/1-parser/cameligo/ParserMain.ml
@@ -78,7 +78,7 @@ let wrap = function
Stdlib.Ok ast ->
if IO.options#pretty then
begin
- let doc = Pretty.make ast in
+ let doc = Pretty.print ast in
let width =
match Terminal_size.get_columns () with
None -> 60
diff --git a/src/passes/1-parser/cameligo/Pretty.ml b/src/passes/1-parser/cameligo/Pretty.ml
index 6da2c7bf9..4351b7bad 100644
--- a/src/passes/1-parser/cameligo/Pretty.ml
+++ b/src/passes/1-parser/cameligo/Pretty.ml
@@ -5,11 +5,13 @@ module Region = Simple_utils.Region
open! Region
open! PPrint
-(*let paragraph (s : string) = flow (break 1) (words s)*)
+let pp_par printer {value; _} =
+ string "(" ^^ nest 1 (printer value.inside ^^ string ")")
-let rec make ast =
+let rec print ast =
let app decl = group (pp_declaration decl) in
- separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
+ let decl = Utils.nseq_to_list ast.decl in
+ separate_map (hardline ^^ hardline) app decl
and pp_declaration = function
Let decl -> pp_let_decl decl
@@ -90,8 +92,7 @@ and pp_nat {value; _} =
and pp_bytes {value; _} =
string ("0x" ^ Hex.show (snd value))
-and pp_ppar {value; _} =
- string "(" ^^ nest 1 (pp_pattern value.inside ^^ string ")")
+and pp_ppar p = pp_par pp_pattern p
and pp_plist = function
PListComp cmp -> pp_list_comp cmp
@@ -345,8 +346,7 @@ and pp_tuple_expr {value; _} =
then pp_expr head
else pp_expr head ^^ string "," ^^ app (List.map snd tail)
-and pp_par_expr {value; _} =
- string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
+and pp_par_expr e = pp_par pp_expr e
and pp_let_in {value; _} =
let {binding; kwd_rec; body; attributes; _} = value in
@@ -425,8 +425,7 @@ and pp_field_decl {value; _} =
let t_expr = pp_type_expr field_type
in prefix 2 1 (name ^^ string " :") t_expr
-and pp_type_app {value; _} =
- let ctor, tuple = value in
+and pp_type_app {value = ctor, tuple; _} =
prefix 2 1 (pp_type_tuple tuple) (pp_type_constr ctor)
and pp_type_tuple {value; _} =
@@ -449,5 +448,4 @@ and pp_fun_type {value; _} =
let lhs, _, rhs = value in
group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
-and pp_type_par {value; _} =
- string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")
+and pp_type_par t = pp_par pp_type_expr t
diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml
index 651306022..e1332b96d 100644
--- a/src/passes/1-parser/cameligo/Scoping.ml
+++ b/src/passes/1-parser/cameligo/Scoping.ml
@@ -22,7 +22,7 @@ module Ord =
struct
type t = AST.variable
let compare v1 v2 =
- compare v1.value v2.value
+ String.compare v1.value v2.value
end
module VarSet = Set.Make (Ord)
diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml
index 685d5c5dd..cf6906b69 100644
--- a/src/passes/1-parser/pascaligo/AST.ml
+++ b/src/passes/1-parser/pascaligo/AST.ml
@@ -106,14 +106,15 @@ type eof = Region.t
(* Literals *)
-type variable = string reg
-type fun_name = string reg
-type type_name = string reg
-type field_name = string reg
-type map_name = string reg
-type set_name = string reg
-type constr = string reg
-type attribute = string reg
+type variable = string reg
+type fun_name = string reg
+type type_name = string reg
+type type_constr = string reg
+type field_name = string reg
+type map_name = string reg
+type set_name = string reg
+type constr = string reg
+type attribute = string reg
(* Parentheses *)
@@ -181,7 +182,7 @@ and type_expr =
TProd of cartesian
| TSum of (variant reg, vbar) nsepseq reg
| TRecord of field_decl reg ne_injection reg
-| TApp of (type_name * type_tuple) reg
+| TApp of (type_constr * type_tuple) reg
| TFun of (type_expr * arrow * type_expr) reg
| TPar of type_expr par reg
| TVar of variable
@@ -215,17 +216,17 @@ and fun_expr = {
}
and fun_decl = {
- kwd_recursive: kwd_recursive option;
- kwd_function : kwd_function;
- fun_name : variable;
- param : parameters;
- colon : colon;
- ret_type : type_expr;
- kwd_is : kwd_is;
- block_with : (block reg * kwd_with) option;
- return : expr;
- terminator : semi option;
- attributes : attr_decl option
+ kwd_recursive : kwd_recursive option;
+ kwd_function : kwd_function;
+ fun_name : variable;
+ param : parameters;
+ colon : colon;
+ ret_type : type_expr;
+ kwd_is : kwd_is;
+ block_with : (block reg * kwd_with) option;
+ return : expr;
+ terminator : semi option;
+ attributes : attr_decl option
}
and parameters = (param_decl, semi) nsepseq par reg
@@ -249,19 +250,14 @@ and param_var = {
}
and block = {
- opening : block_opening;
+ enclosing : block_enclosing;
statements : statements;
- terminator : semi option;
- closing : block_closing
+ terminator : semi option
}
-and block_opening =
- Block of kwd_block * lbrace
-| Begin of kwd_begin
-
-and block_closing =
- Block of rbrace
-| End of kwd_end
+and block_enclosing =
+ Block of kwd_block * lbrace * rbrace
+| BeginEnd of kwd_begin * kwd_end
and statements = (statement, semi) nsepseq
@@ -378,10 +374,10 @@ and set_membership = {
and 'a case = {
kwd_case : kwd_case;
expr : expr;
- opening : opening;
+ kwd_of : kwd_of;
+ enclosing : enclosing;
lead_vbar : vbar option;
- cases : ('a case_clause reg, vbar) nsepseq reg;
- closing : closing
+ cases : ('a case_clause reg, vbar) nsepseq reg
}
and 'a case_clause = {
@@ -471,34 +467,12 @@ and expr =
| EPar of expr par reg
| EFun of fun_expr reg
-and annot_expr = (expr * type_expr)
+and annot_expr = expr * type_expr
and set_expr =
SetInj of expr injection reg
| SetMem of set_membership reg
-and 'a injection = {
- opening : opening;
- elements : ('a, semi) sepseq;
- terminator : semi option;
- closing : closing
-}
-
-and 'a ne_injection = {
- opening : opening;
- ne_elements : ('a, semi) nsepseq;
- terminator : semi option;
- closing : closing
-}
-
-and opening =
- Kwd of keyword
-| KwdBracket of keyword * lbracket
-
-and closing =
- End of kwd_end
-| RBracket of rbracket
-
and map_expr =
MapLookUp of map_lookup reg
| MapInj of binding reg injection reg
@@ -520,7 +494,7 @@ and logic_expr =
and bool_expr =
Or of kwd_or bin_op reg
| And of kwd_and bin_op reg
-| Not of kwd_not un_op reg
+| Not of kwd_not un_op reg
| False of c_False
| True of c_True
@@ -544,15 +518,15 @@ and comp_expr =
| Neq of neq bin_op reg
and arith_expr =
- Add of plus bin_op reg
-| Sub of minus bin_op reg
-| Mult of times bin_op reg
-| Div of slash bin_op reg
-| Mod of kwd_mod bin_op reg
-| Neg of minus un_op reg
-| Int of (Lexer.lexeme * Z.t) reg
-| Nat of (Lexer.lexeme * Z.t) reg
-| Mutez of (Lexer.lexeme * Z.t) reg
+ Add of plus bin_op reg
+| Sub of minus bin_op reg
+| Mult of times bin_op reg
+| Div of slash bin_op reg
+| Mod of kwd_mod bin_op reg
+| Neg of minus un_op reg
+| Int of (Lexer.lexeme * Z.t) reg
+| Nat of (Lexer.lexeme * Z.t) reg
+| Mutez of (Lexer.lexeme * Z.t) reg
and string_expr =
Cat of cat bin_op reg
@@ -584,14 +558,14 @@ and projection = {
}
and update = {
- record : path;
+ record : path;
kwd_with : kwd_with;
- updates : field_path_assign reg ne_injection reg
+ updates : field_path_assign reg ne_injection reg
}
and field_path_assign = {
- field_path : (field_name, dot) nsepseq;
- equal : equal;
+ field_path : (field_name, dot) nsepseq;
+ equal : equal;
field_expr : expr
}
@@ -605,6 +579,38 @@ and fun_call = (expr * arguments) reg
and arguments = tuple_expr
+(* Injections *)
+
+and 'a injection = {
+ kind : injection_kwd;
+ enclosing : enclosing;
+ elements : ('a, semi) sepseq;
+ terminator : semi option
+}
+
+and injection_kwd =
+ InjSet of keyword
+| InjMap of keyword
+| InjBigMap of keyword
+| InjList of keyword
+
+and enclosing =
+ Brackets of lbracket * rbracket
+| End of kwd_end
+
+and 'a ne_injection = {
+ kind : ne_injection_kwd;
+ enclosing : enclosing;
+ ne_elements : ('a, semi) nsepseq;
+ terminator : semi option
+}
+
+and ne_injection_kwd =
+ NEInjAttr of keyword
+| NEInjSet of keyword
+| NEInjMap of keyword
+| NEInjRecord of keyword
+
(* Patterns *)
and pattern =
@@ -635,7 +641,7 @@ and list_pattern =
| PCons of (pattern, cons) nsepseq reg
-(* Projecting regions *)
+(* PROJECTING REGIONS *)
let rec last to_region = function
[] -> Region.ghost
diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly
index 669ee7dbd..753354cfd 100644
--- a/src/passes/1-parser/pascaligo/Parser.mly
+++ b/src/passes/1-parser/pascaligo/Parser.mly
@@ -122,7 +122,8 @@ attr_decl:
open_attr_decl ";"? { $1 }
open_attr_decl:
- ne_injection("attributes","") { $1 }
+ ne_injection("attributes","") {
+ $1 (fun region -> NEInjAttr region) }
(* Type declarations *)
@@ -214,19 +215,19 @@ record_type:
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
- and value = {opening = Kwd $1;
+ and value = {kind = NEInjRecord $1;
+ enclosing = End $3;
ne_elements;
- terminator;
- closing = End $3}
+ terminator}
in TRecord {region; value}
}
| "record" "[" sep_or_term_list(field_decl,";") "]" {
let ne_elements, terminator = $3 in
let region = cover $1 $4
- and value = {opening = KwdBracket ($1,$2);
+ and value = {kind = NEInjRecord $1;
+ enclosing = Brackets ($2,$4);
ne_elements;
- terminator;
- closing = RBracket $4}
+ terminator}
in TRecord {region; value} }
field_decl:
@@ -238,7 +239,7 @@ field_decl:
fun_expr:
- | ioption ("recursive") "function" parameters ":" type_expr "is" expr {
+ ioption ("recursive") "function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $7 in
let region = cover $2 stop
and value = {kwd_recursive= $1;
@@ -271,7 +272,8 @@ open_fun_decl:
attributes = None}
in {region; value}
}
-| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
+| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
+ expr {
Scoping.check_reserved_name $3;
let stop = expr_to_region $8 in
let region = cover $2 stop
@@ -326,19 +328,17 @@ block:
"begin" sep_or_term_list(statement,";") "end" {
let statements, terminator = $2 in
let region = cover $1 $3
- and value = {opening = Begin $1;
+ and value = {enclosing = BeginEnd ($1,$3);
statements;
- terminator;
- closing = End $3}
+ terminator}
in {region; value}
}
| "block" "{" sep_or_term_list(statement,";") "}" {
let statements, terminator = $3 in
let region = cover $1 $4
- and value = {opening = Block ($1,$2);
+ and value = {enclosing = Block ($1,$2,$4);
statements;
- terminator;
- closing = Block $4}
+ terminator}
in {region; value} }
statement:
@@ -404,124 +404,122 @@ instruction:
set_remove:
"remove" expr "from" "set" path {
let region = cover $1 (path_to_region $5) in
- let value = {
- kwd_remove = $1;
- element = $2;
- kwd_from = $3;
- kwd_set = $4;
- set = $5}
+ let value = {kwd_remove = $1;
+ element = $2;
+ kwd_from = $3;
+ kwd_set = $4;
+ set = $5}
in {region; value} }
map_remove:
"remove" expr "from" "map" path {
let region = cover $1 (path_to_region $5) in
- let value = {
- kwd_remove = $1;
- key = $2;
- kwd_from = $3;
- kwd_map = $4;
- map = $5}
+ let value = {kwd_remove = $1;
+ key = $2;
+ kwd_from = $3;
+ kwd_map = $4;
+ map = $5}
in {region; value} }
set_patch:
"patch" path "with" ne_injection("set",expr) {
- let region = cover $1 $4.region in
- let value = {
- kwd_patch = $1;
- path = $2;
- kwd_with = $3;
- set_inj = $4}
+ let set_inj = $4 (fun region -> NEInjSet region) in
+ let region = cover $1 set_inj.region in
+ let value = {kwd_patch = $1;
+ path = $2;
+ kwd_with = $3;
+ set_inj}
in {region; value} }
map_patch:
"patch" path "with" ne_injection("map",binding) {
- let region = cover $1 $4.region in
- let value = {
- kwd_patch = $1;
- path = $2;
- kwd_with = $3;
- map_inj = $4}
+ let map_inj = $4 (fun region -> NEInjMap region) in
+ let region = cover $1 map_inj.region in
+ let value = {kwd_patch = $1;
+ path = $2;
+ kwd_with = $3;
+ map_inj}
in {region; value} }
injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
- let elements, terminator = $2 in
- let region = cover $1 $3
- and value = {
- opening = Kwd $1;
- elements = Some elements;
- terminator;
- closing = End $3}
- in {region; value}
+ fun mk_kwd ->
+ let elements, terminator = $2 in
+ let region = cover $1 $3
+ and value = {
+ kind = mk_kwd $1;
+ enclosing = End $3;
+ elements = Some elements;
+ terminator}
+ in {region; value}
}
| Kind "end" {
- let region = cover $1 $2
- and value = {
- opening = Kwd $1;
- elements = None;
- terminator = None;
- closing = End $2}
- in {region; value}
+ fun mk_kwd ->
+ let region = cover $1 $2
+ and value = {kind = mk_kwd $1;
+ enclosing = End $2;
+ elements = None;
+ terminator = None}
+ in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
- let elements, terminator = $3 in
- let region = cover $1 $4
- and value = {
- opening = KwdBracket ($1,$2);
- elements = Some elements;
- terminator;
- closing = RBracket $4}
- in {region; value}
+ fun mk_kwd ->
+ let elements, terminator = $3 in
+ let region = cover $1 $4
+ and value = {kind = mk_kwd $1;
+ enclosing = Brackets ($2,$4);
+ elements = Some elements;
+ terminator}
+ in {region; value}
}
| Kind "[" "]" {
- let region = cover $1 $3
- and value = {
- opening = KwdBracket ($1,$2);
- elements = None;
- terminator = None;
- closing = RBracket $3}
- in {region; value} }
+ fun mk_kwd ->
+ let region = cover $1 $3
+ and value = {kind = mk_kwd $1;
+ enclosing = Brackets ($2,$3);
+ elements = None;
+ terminator = None}
+ in {region; value} }
ne_injection(Kind,element):
Kind sep_or_term_list(element,";") "end" {
- let ne_elements, terminator = $2 in
- let region = cover $1 $3
- and value = {
- opening = Kwd $1;
- ne_elements;
- terminator;
- closing = End $3}
- in {region; value}
+ fun mk_kwd ->
+ let ne_elements, terminator = $2 in
+ let region = cover $1 $3
+ and value = {kind = mk_kwd $1;
+ enclosing = End $3;
+ ne_elements;
+ terminator}
+ in {region; value}
}
| Kind "[" sep_or_term_list(element,";") "]" {
- let ne_elements, terminator = $3 in
- let region = cover $1 $4
- and value = {
- opening = KwdBracket ($1,$2);
- ne_elements;
- terminator;
- closing = RBracket $4}
- in {region; value} }
+ fun mk_kwd ->
+ let ne_elements, terminator = $3 in
+ let region = cover $1 $4
+ and value = {kind = mk_kwd $1;
+ enclosing = Brackets ($2,$4);
+ ne_elements;
+ terminator}
+ in {region; value} }
binding:
expr "->" expr {
let start = expr_to_region $1
and stop = expr_to_region $3 in
let region = cover start stop
- and value = {
- source = $1;
- arrow = $2;
- image = $3}
+ and value = {source = $1;
+ arrow = $2;
+ image = $3}
in {region; value} }
record_patch:
"patch" path "with" ne_injection("record",field_assignment) {
- let region = cover $1 $4.region in
- let value = {
- kwd_patch = $1;
- path = $2;
- kwd_with = $3;
- record_inj = $4}
+ let record_inj = $4 (fun region -> NEInjRecord region) in
+ let region = cover $1 record_inj.region in
+ let value = {kwd_patch = $1;
+ path = $2;
+ kwd_with = $3;
+ record_inj}
in {region; value} }
proc_call:
@@ -547,12 +545,9 @@ if_clause:
clause_block:
block { LongBlock $1 }
| "{" sep_or_term_list(statement,";") "}" {
- let statements, terminator = $2 in
let region = cover $1 $3 in
- let value = {lbrace = $1;
- inside = statements, terminator;
- rbrace = $3} in
- ShortBlock {value; region} }
+ let value = {lbrace=$1; inside=$2; rbrace=$3}
+ in ShortBlock {value; region} }
case_instr:
case(if_clause) { $1 if_clause_to_region }
@@ -563,10 +558,10 @@ case(rhs):
let region = cover $1 $6 in
let value = {kwd_case = $1;
expr = $2;
- opening = Kwd $3;
+ kwd_of = $3;
+ enclosing = End $6;
lead_vbar = $4;
- cases = $5 rhs_to_region;
- closing = End $6}
+ cases = $5 rhs_to_region}
in {region; value}
}
| "case" expr "of" "[" "|"? cases(rhs) "]" {
@@ -574,10 +569,10 @@ case(rhs):
let region = cover $1 $7 in
let value = {kwd_case = $1;
expr = $2;
- opening = KwdBracket ($3,$4);
+ kwd_of = $3;
+ enclosing = Brackets ($4,$7);
lead_vbar = $5;
- cases = $6 rhs_to_region;
- closing = RBracket $7}
+ cases = $6 rhs_to_region}
in {region; value} }
cases(rhs):
@@ -904,12 +899,17 @@ annot_expr:
in {region; value} }
set_expr:
- injection("set",expr) { SetInj $1 }
+ injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
map_expr:
- map_lookup { MapLookUp $1 }
-| injection("map",binding) { MapInj $1 }
-| injection("big_map",binding) { BigMapInj $1 }
+ map_lookup {
+ MapLookUp $1
+ }
+| injection("map",binding) {
+ MapInj ($1 (fun region -> InjMap region))
+ }
+| injection("big_map",binding) {
+ BigMapInj ($1 (fun region -> InjBigMap region)) }
map_lookup:
path brackets(expr) {
@@ -958,26 +958,27 @@ record_expr:
let ne_elements, terminator = $2 in
let region = cover $1 $3
and value : field_assign AST.reg ne_injection = {
- opening = Kwd $1;
+ kind = NEInjRecord $1;
+ enclosing = End $3;
ne_elements;
- terminator;
- closing = End $3}
+ terminator}
in {region; value}
}
| "record" "[" sep_or_term_list(field_assignment,";") "]" {
- let ne_elements, terminator = $3 in
- let region = cover $1 $4
- and value : field_assign AST.reg ne_injection = {
- opening = KwdBracket ($1,$2);
- ne_elements;
- terminator;
- closing = RBracket $4}
- in {region; value} }
+ let ne_elements, terminator = $3 in
+ let region = cover $1 $4
+ and value : field_assign AST.reg ne_injection = {
+ kind = NEInjRecord $1;
+ enclosing = Brackets ($2,$4);
+ ne_elements;
+ terminator}
+ in {region; value} }
update_record:
- path "with" ne_injection("record",field_path_assignment){
- let region = cover (path_to_region $1) $3.region in
- let value = {record=$1; kwd_with=$2; updates=$3}
+ path "with" ne_injection("record",field_path_assignment) {
+ let updates = $3 (fun region -> NEInjRecord region) in
+ let region = cover (path_to_region $1) updates.region in
+ let value = {record=$1; kwd_with=$2; updates}
in {region; value} }
field_assignment:
@@ -1010,8 +1011,8 @@ arguments:
par(nsepseq(expr,",")) { $1 }
list_expr:
- injection("list",expr) { EListComp $1 }
-| "nil" { ENil $1 }
+ injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
+| "nil" { ENil $1 }
(* Patterns *)
@@ -1034,9 +1035,10 @@ core_pattern:
| constr_pattern { PConstr $1 }
list_pattern:
- injection("list",core_pattern) { PListComp $1 }
-| "nil" { PNil $1 }
+ "nil" { PNil $1 }
| par(cons_pattern) { PParCons $1 }
+| injection("list",core_pattern) {
+ PListComp ($1 (fun region -> InjList region)) }
cons_pattern:
core_pattern "#" pattern { $1,$2,$3 }
diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml
index eb694f48b..6ae1ca0ac 100644
--- a/src/passes/1-parser/pascaligo/ParserLog.ml
+++ b/src/passes/1-parser/pascaligo/ParserLog.ml
@@ -27,11 +27,11 @@ let mk_state ~offsets ~mode ~buffer =
val pad_node = ""
method pad_node = pad_node
- (** The method [pad] updates the current padding, which is
- comprised of two components: the padding to reach the new node
- (space before reaching a subtree, then a vertical bar for it)
- and the padding for the new node itself (Is it the last child
- of its parent?).
+ (* The method [pad] updates the current padding, which is
+ comprised of two components: the padding to reach the new node
+ (space before reaching a subtree, then a vertical bar for it)
+ and the padding for the new node itself (Is it the last child
+ of its parent?).
*)
method pad arity rank =
{< pad_path =
@@ -44,7 +44,7 @@ let mk_state ~offsets ~mode ~buffer =
let compact state (region: Region.t) =
region#compact ~offsets:state#offsets state#mode
-(** {1 Printing the tokens with their source regions} *)
+(* Printing the tokens with their source regions *)
let print_nsepseq :
state -> string -> (state -> 'a -> unit) ->
@@ -117,7 +117,7 @@ let rec print_tokens state ast =
print_token state eof "EOF"
and print_attr_decl state =
- print_ne_injection state "attributes" print_string
+ print_ne_injection state print_string
and print_decl state = function
TypeDecl decl -> print_type_decl state decl
@@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
and print_sum_type state {value; _} =
print_nsepseq state "|" print_variant value
-and print_record_type state record_type =
- print_ne_injection state "record" print_field_decl record_type
+and print_record_type state =
+ print_ne_injection state print_field_decl
and print_type_app state {value; _} =
let type_name, type_tuple = value in
@@ -256,22 +256,19 @@ and print_param_var state {value; _} =
print_type_expr state param_type
and print_block state block =
- let {opening; statements; terminator; closing} = block.value in
- print_block_opening state opening;
- print_statements state statements;
- print_terminator state terminator;
- print_block_closing state closing
-
-and print_block_opening state = function
- Block (kwd_block, lbrace) ->
- print_token state kwd_block "block";
- print_token state lbrace "{"
-| Begin kwd_begin ->
- print_token state kwd_begin "begin"
-
-and print_block_closing state = function
- Block rbrace -> print_token state rbrace "}"
-| End kwd_end -> print_token state kwd_end "end"
+ let {enclosing; statements; terminator} = block.value in
+ match enclosing with
+ Block (kwd_block, lbrace, rbrace) ->
+ print_token state kwd_block "block";
+ print_token state lbrace "{";
+ print_statements state statements;
+ print_terminator state terminator;
+ print_token state rbrace "}"
+ | BeginEnd (kwd_begin, kwd_end) ->
+ print_token state kwd_begin "begin";
+ print_statements state statements;
+ print_terminator state terminator;
+ print_token state kwd_end "end"
and print_data_decl state = function
LocalConst decl -> print_const_decl state decl
@@ -344,14 +341,20 @@ and print_clause_block state = function
print_token state rbrace "}"
and print_case_instr state (node : if_clause case) =
- let {kwd_case; expr; opening;
- lead_vbar; cases; closing} = node in
+ let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
- print_opening state "of" opening;
- print_token_opt state lead_vbar "|";
- print_cases_instr state cases;
- print_closing state closing
+ print_token state kwd_of "of";
+ match enclosing with
+ Brackets (lbracket, rbracket) ->
+ print_token state lbracket "[";
+ print_token_opt state lead_vbar "|";
+ print_cases_instr state cases;
+ print_token state rbracket "]"
+ | End kwd_end ->
+ print_token_opt state lead_vbar "|";
+ print_cases_instr state cases;
+ print_token state kwd_end "end"
and print_token_opt state = function
None -> fun _ -> ()
@@ -466,14 +469,20 @@ and print_annot_expr state (expr , type_expr) =
print_type_expr state type_expr
and print_case_expr state (node : expr case) =
- let {kwd_case; expr; opening;
- lead_vbar; cases; closing} = node in
+ let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
print_token state kwd_case "case";
print_expr state expr;
- print_opening state "of" opening;
- print_token_opt state lead_vbar "|";
- print_cases_expr state cases;
- print_closing state closing
+ print_token state kwd_of "of";
+ match enclosing with
+ Brackets (lbracket, rbracket) ->
+ print_token state lbracket "[";
+ print_token_opt state lead_vbar "|";
+ print_cases_expr state cases;
+ print_token state rbracket "]"
+ | End kwd_end ->
+ print_token_opt state lead_vbar "|";
+ print_cases_expr state cases;
+ print_token state kwd_end "end"
and print_cases_expr state {value; _} =
print_nsepseq state "|" print_case_clause_expr value
@@ -486,11 +495,11 @@ and print_case_clause_expr state {value; _} =
and print_map_expr state = function
MapLookUp {value; _} -> print_map_lookup state value
-| MapInj inj -> print_injection state "map" print_binding inj
-| BigMapInj inj -> print_injection state "big_map" print_binding inj
+| MapInj inj -> print_injection state print_binding inj
+| BigMapInj inj -> print_injection state print_binding inj
and print_set_expr state = function
- SetInj inj -> print_injection state "set" print_expr inj
+ SetInj inj -> print_injection state print_expr inj
| SetMem mem -> print_set_membership state mem
and print_set_membership state {value; _} =
@@ -600,7 +609,7 @@ and print_list_expr state = function
print_expr state arg1;
print_token state op "#";
print_expr state arg2
-| EListComp e -> print_injection state "list" print_expr e
+| EListComp e -> print_injection state print_expr e
| ENil e -> print_nil state e
and print_constr_expr state = function
@@ -608,8 +617,8 @@ and print_constr_expr state = function
| NoneExpr e -> print_none_expr state e
| ConstrApp e -> print_constr_app state e
-and print_record_expr state e =
- print_ne_injection state "record" print_field_assign e
+and print_record_expr state =
+ print_ne_injection state print_field_assign
and print_field_assign state {value; _} =
let {field_name; equal; field_expr} = value in
@@ -627,8 +636,7 @@ and print_update_expr state {value; _} =
let {record; kwd_with; updates} = value in
print_path state record;
print_token state kwd_with "with";
- print_ne_injection state "updates field" print_field_path_assign updates
-
+ print_ne_injection state print_field_path_assign updates
and print_projection state {value; _} =
let {struct_name; selector; field_path} = value in
@@ -648,21 +656,21 @@ and print_record_patch state node =
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
- print_ne_injection state "record" print_field_assign record_inj
+ print_ne_injection state print_field_assign record_inj
and print_set_patch state node =
let {kwd_patch; path; kwd_with; set_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
- print_ne_injection state "set" print_expr set_inj
+ print_ne_injection state print_expr set_inj
and print_map_patch state node =
let {kwd_patch; path; kwd_with; map_inj} = node in
print_token state kwd_patch "patch";
print_path state path;
print_token state kwd_with "with";
- print_ne_injection state "map" print_binding map_inj
+ print_ne_injection state print_binding map_inj
and print_map_remove state node =
let {kwd_remove; key; kwd_from; kwd_map; map} = node in
@@ -681,35 +689,48 @@ and print_set_remove state node =
print_path state set
and print_injection :
- 'a.state -> string -> (state -> 'a -> unit) ->
- 'a injection reg -> unit =
- fun state kwd print {value; _} ->
- let {opening; elements; terminator; closing} = value in
- print_opening state kwd opening;
- print_sepseq state ";" print elements;
- print_terminator state terminator;
- print_closing state closing
+ 'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
+ fun state print {value; _} ->
+ let {kind; enclosing; elements; terminator} = value in
+ print_injection_kwd state kind;
+ match enclosing with
+ Brackets (lbracket, rbracket) ->
+ print_token state lbracket "[";
+ print_sepseq state ";" print elements;
+ print_terminator state terminator;
+ print_token state rbracket "]"
+ | End kwd_end ->
+ print_sepseq state ";" print elements;
+ print_terminator state terminator;
+ print_token state kwd_end "end"
+
+and print_injection_kwd state = function
+ InjSet kwd_set -> print_token state kwd_set "set"
+| InjMap kwd_map -> print_token state kwd_map "map"
+| InjBigMap kwd_big_map -> print_token state kwd_big_map "big_map"
+| InjList kwd_list -> print_token state kwd_list "list"
and print_ne_injection :
- 'a.state -> string -> (state -> 'a -> unit) ->
- 'a ne_injection reg -> unit =
- fun state kwd print {value; _} ->
- let {opening; ne_elements; terminator; closing} = value in
- print_opening state kwd opening;
- print_nsepseq state ";" print ne_elements;
- print_terminator state terminator;
- print_closing state closing
+ 'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
+ fun state print {value; _} ->
+ let {kind; enclosing; ne_elements; terminator} = value in
+ print_ne_injection_kwd state kind;
+ match enclosing with
+ Brackets (lbracket, rbracket) ->
+ print_token state lbracket "[";
+ print_nsepseq state ";" print ne_elements;
+ print_terminator state terminator;
+ print_token state rbracket "]"
+ | End kwd_end ->
+ print_nsepseq state ";" print ne_elements;
+ print_terminator state terminator;
+ print_token state kwd_end "end"
-and print_opening state lexeme = function
- Kwd kwd ->
- print_token state kwd lexeme
-| KwdBracket (kwd, lbracket) ->
- print_token state kwd lexeme;
- print_token state lbracket "["
-
-and print_closing state = function
- RBracket rbracket -> print_token state rbracket "]"
-| End kwd_end -> print_token state kwd_end "end"
+and print_ne_injection_kwd state = function
+ NEInjAttr kwd_attributes -> print_token state kwd_attributes "attributes"
+| NEInjSet kwd_set -> print_token state kwd_set "set"
+| NEInjMap kwd_map -> print_token state kwd_map "map"
+| NEInjRecord kwd_record -> print_token state kwd_record "record"
and print_binding state {value; _} =
let {source; arrow; image} = value in
@@ -787,7 +808,7 @@ and print_patterns state {value; _} =
and print_list_pattern state = function
PListComp comp ->
- print_injection state "list" print_pattern comp
+ print_injection state print_pattern comp
| PNil kwd_nil ->
print_token state kwd_nil "nil"
| PParCons cons ->
@@ -831,7 +852,7 @@ let pattern_to_string ~offsets ~mode =
let instruction_to_string ~offsets ~mode =
to_string ~offsets ~mode print_instruction
-(** {1 Pretty-printing the AST} *)
+(* Pretty-printing the AST *)
let pp_ident state {value=name; region} =
let reg = compact state region in
@@ -952,8 +973,8 @@ and pp_type_expr state = function
let fields = Utils.nsepseq_to_list value.ne_elements in
List.iteri (List.length fields |> apply) fields
| TString s ->
- pp_node state "TString";
- pp_string (state#pad 1 0) s
+ pp_node state "TString";
+ pp_string (state#pad 1 0) s
and pp_cartesian state {value; _} =
let apply len rank =
diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml
index f0485222b..65533dc14 100644
--- a/src/passes/1-parser/pascaligo/ParserMain.ml
+++ b/src/passes/1-parser/pascaligo/ParserMain.ml
@@ -75,9 +75,23 @@ module Unit =
(* Main *)
let wrap = function
- Stdlib.Ok _ -> flush_all ()
+ Stdlib.Ok ast ->
+ if IO.options#pretty then
+ begin
+ let doc = Pretty.print ast in
+ let width =
+ match Terminal_size.get_columns () with
+ None -> 60
+ | Some c -> c in
+ PPrint.ToChannel.pretty 1.0 width stdout doc;
+ print_newline ()
+ end;
+ flush_all ()
| Error msg ->
- (flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
+ begin
+ flush_all ();
+ Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
+ end
let () =
match IO.options#input with
diff --git a/src/passes/1-parser/pascaligo/Pretty.ml b/src/passes/1-parser/pascaligo/Pretty.ml
new file mode 100644
index 000000000..442532393
--- /dev/null
+++ b/src/passes/1-parser/pascaligo/Pretty.ml
@@ -0,0 +1,500 @@
+[@@@warning "-42"]
+[@@@warning "-27"]
+[@@@warning "-26"]
+
+open AST
+module Region = Simple_utils.Region
+open! Region
+open! PPrint
+
+let pp_par (printer: 'a -> document) ({value; _} : 'a par reg) =
+ string "(" ^^ nest 1 (printer value.inside ^^ string ")")
+
+let rec print ast =
+ let app decl = group (pp_declaration decl) in
+ let decl = Utils.nseq_to_list ast.decl in
+ separate_map (hardline ^^ hardline) app decl
+
+and pp_declaration = function
+ TypeDecl d -> pp_type_decl d
+| ConstDecl d -> pp_const_decl d
+| FunDecl d -> pp_fun_decl d
+| AttrDecl d -> pp_attr_decl d
+
+and pp_attr_decl decl = pp_ne_injection pp_string decl
+
+and pp_const_decl {value; _} =
+ let {name; const_type; init; attributes; _} = value in
+ let start = string ("const " ^ name.value ^ " :") in
+ let t_expr = pp_type_expr const_type in
+ let attr = match attributes with
+ None -> empty
+ | Some a -> hardline ^^ pp_attr_decl a
+ in prefix 2 1 start t_expr
+ ^/^ prefix 2 1 (string "=") (pp_expr init)
+ ^^ attr
+
+(* Type declarations *)
+
+and pp_type_decl decl =
+ let {name; type_expr; _} = decl.value in
+ string "type " ^^ string name.value ^^ string " is"
+ ^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
+
+and pp_type_expr = function
+ TProd t -> pp_cartesian t
+| TSum t -> pp_variants t
+| TRecord t -> pp_fields t
+| TApp t -> pp_type_app t
+| TFun t -> pp_fun_type t
+| TPar t -> pp_type_par t
+| TVar t -> pp_ident t
+| TString s -> pp_string s
+
+and pp_cartesian {value; _} =
+ let head, tail = value in
+ let rec app = function
+ [] -> empty
+ | [e] -> group (break 1 ^^ pp_type_expr e)
+ | e::items ->
+ group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
+ in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
+
+and pp_variants {value; _} =
+ let head, tail = value in
+ let head = pp_variant head in
+ let head = if tail = [] then head
+ else ifflat head (string " " ^^ head) in
+ let rest = List.map snd tail in
+ let app variant = break 1 ^^ string "| " ^^ pp_variant variant
+ in head ^^ concat_map app rest
+
+and pp_variant {value; _} =
+ let {constr; arg} = value in
+ match arg with
+ None -> pp_ident constr
+ | Some (_, e) ->
+ prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
+
+and pp_fields fields = pp_ne_injection pp_field_decl fields
+
+and pp_field_decl {value; _} =
+ let {field_name; field_type; _} = value in
+ let name = pp_ident field_name in
+ let t_expr = pp_type_expr field_type
+ in prefix 2 1 (name ^^ string " :") t_expr
+
+and pp_fun_type {value; _} =
+ let lhs, _, rhs = value in
+ group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
+
+and pp_type_par t = pp_par pp_type_expr t
+
+and pp_type_app {value = ctor, tuple; _} =
+ prefix 2 1 (pp_type_constr ctor) (pp_type_tuple tuple)
+
+and pp_type_constr ctor = string ctor.value
+
+and pp_type_tuple {value; _} =
+ let head, tail = value.inside in
+ let rec app = function
+ [] -> empty
+ | [e] -> group (break 1 ^^ pp_type_expr e)
+ | e::items ->
+ group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
+ let components =
+ if tail = []
+ then pp_type_expr head
+ else pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
+ in string "(" ^^ nest 1 (components ^^ string ")")
+
+(* Function and procedure declarations *)
+
+and pp_fun_expr {value; _} = string "TODO:pp_fun_expr"
+
+and pp_fun_decl {value; _} =
+ let {kwd_recursive; fun_name; param;
+ ret_type; block_with; return; attributes; _} = value in
+ let start =
+ match kwd_recursive with
+ None -> string "function"
+ | Some _ -> string "recursive" ^/^ string "function" in
+ let parameters = pp_par pp_parameters param in
+ let return_t = pp_type_expr ret_type in
+ let blk_opening, blk_in, blk_closing =
+ match block_with with
+ None -> empty, empty, empty
+ | Some (b,_) ->
+ hardline ^^ string "is block [", pp_block b, string "] with " in
+ let expr = pp_expr return in
+ let attr = match attributes with
+ None -> empty
+ | Some a -> hardline ^^ pp_attr_decl a
+ in group (start ^^ nest 2 (break 1 ^^ parameters))
+ ^/^ string ": " ^^ nest 2 return_t
+ ^^ blk_opening
+ ^^ nest 2 (break 0 ^^ blk_in)
+ ^/^ blk_closing ^^ nest 4 (break 1 ^^ expr)
+ ^^ attr
+
+and pp_parameters p = pp_nsepseq ";" pp_param_decl p
+
+and pp_param_decl = function
+ ParamConst c -> pp_param_const c
+| ParamVar v -> pp_param_var v
+
+and pp_param_const {value; _} =
+ let {var; param_type; _} : param_const = value in
+ let name = string ("const " ^ var.value) in
+ let t_expr = pp_type_expr param_type
+ in prefix 2 1 (name ^^ string " :") t_expr
+
+and pp_param_var {value; _} =
+ let {var; param_type; _} : param_var = value in
+ let name = string ("var " ^ var.value) in
+ let t_expr = pp_type_expr param_type
+ in prefix 2 1 (name ^^ string " :") t_expr
+
+and pp_block {value; _} = pp_statements value.statements
+
+and pp_statements s = pp_nsepseq ";" pp_statement s
+
+and pp_statement = function
+ Instr s -> pp_instruction s
+| Data s -> pp_data_decl s
+| Attr s -> pp_attr_decl s
+
+and pp_data_decl = function
+ LocalConst d -> pp_const_decl d
+| LocalVar d -> pp_var_decl d
+| LocalFun d -> pp_fun_decl d
+
+and pp_var_decl {value; _} =
+ let {name; var_type; init; _} = value in
+ let start = string ("var " ^ name.value ^ " :") in
+ let t_expr = pp_type_expr var_type
+ in prefix 2 1 start t_expr
+ ^/^ prefix 2 1 (string ":=") (pp_expr init)
+
+and pp_instruction = function
+ Cond i -> pp_conditional i
+| CaseInstr i -> pp_case pp_if_clause i
+| Assign i -> pp_assignment i
+| Loop i -> pp_loop i
+| ProcCall i -> pp_fun_call i
+| Skip _ -> string "skip"
+| RecordPatch i -> pp_record_patch i
+| MapPatch i -> pp_map_patch i
+| SetPatch i -> pp_set_patch i
+| MapRemove i -> pp_map_remove i
+| SetRemove i -> pp_set_remove i
+
+and pp_set_remove {value; _} = string "TODO:pp_set_remove"
+
+and pp_map_remove {value; _} = string "TODO:pp_map_remove"
+
+and pp_set_patch {value; _} = string "TODO:pp_set_patch"
+
+and pp_map_patch {value; _} = string "TODO:pp_map_patch"
+
+and pp_binding b = string "TODO:pp_binding"
+
+and pp_record_patch {value; _} = string "TODO:pp_record_patch"
+
+and pp_cond_expr {value; _} = string "TODO:pp_cond_expr"
+
+and pp_conditional {value; _} =
+ let {test; ifso; ifnot; _} : conditional = value in
+ let if_then =
+ string "if " ^^ group (nest 3 (pp_expr test)) ^/^ string "then"
+ ^^ group (nest 2 (break 1 ^^ pp_if_clause ifso)) in
+ let if_else =
+ string "else" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot))
+ in if_then ^/^ if_else
+
+and pp_if_clause = function
+ ClauseInstr i -> pp_instruction i
+| ClauseBlock b -> pp_clause_block b
+
+and pp_clause_block = function
+ LongBlock b -> pp_block b
+| ShortBlock b -> pp_short_block b
+
+and pp_short_block {value; _} = string "TODO:pp_short_block"
+
+and pp_set_membership {value; _} = string "TODO:pp_set_membership"
+
+and pp_case :
+ 'a.('a -> document) -> 'a case Region.reg -> document =
+ fun printer {value; _} ->
+ let {expr; cases; _} = value in
+ group (string "case " ^^ nest 5 (pp_expr expr) ^/^ string "of")
+ ^^ hardline ^^ nest 2 (pp_cases printer cases)
+
+and pp_cases :
+ 'a.('a -> document) ->
+ ('a case_clause reg, vbar) Utils.nsepseq Region.reg -> document =
+ fun printer {value; _} ->
+ let head, tail = value in
+ let head = pp_case_clause printer head in
+ let head = if tail = [] then head
+ else string " " ^^ head in
+ let rest = List.map snd tail in
+ let app clause =
+ break 1 ^^ string "| " ^^ pp_case_clause printer clause
+ in head ^^ concat_map app rest
+
+and pp_case_clause :
+ 'a.('a -> document) -> 'a case_clause Region.reg -> document =
+ fun printer clause -> string "TODO:pp_case_clause"
+
+and pp_assignment {value; _} =
+ let {lhs; rhs; _} = value in
+ prefix 2 1 (pp_lhs lhs ^^ string " :=") (pp_expr rhs)
+
+and pp_lhs : lhs -> document = function
+ Path p -> pp_path p
+| MapPath p -> pp_map_lookup p
+
+and pp_loop = function
+ While l -> pp_while_loop l
+| For f -> pp_for_loop f
+
+and pp_while_loop {value; _} = string "TODO:pp_while_loop"
+
+and pp_for_loop = function
+ ForInt l -> pp_for_int l
+| ForCollect l -> pp_for_collect l
+
+and pp_for_int {value; _} = string "TODO:pp_for_int"
+
+and pp_var_assign {value; _} = string "TODO:pp_var_assign"
+
+and pp_for_collect {value; _} = string "TODO:pp_for_collect"
+
+and pp_collection = function
+ Map _ -> string "map"
+| Set _ -> string "set"
+| List _ -> string "list"
+
+(* Expressions *)
+
+and pp_expr = function
+ ECase e -> pp_case pp_expr e
+| ECond e -> pp_cond_expr e
+| EAnnot e -> pp_annot_expr e
+| ELogic e -> pp_logic_expr e
+| EArith e -> pp_arith_expr e
+| EString e -> pp_string_expr e
+| EList e -> pp_list_expr e
+| ESet e -> pp_set_expr e
+| EConstr e -> pp_constr_expr e
+| ERecord e -> pp_record e
+| EProj e -> pp_projection e
+| EUpdate e -> pp_update e
+| EMap e -> pp_map_expr e
+| EVar e -> pp_ident e
+| ECall e -> pp_fun_call e
+| EBytes e -> pp_bytes e
+| EUnit _ -> string "Unit"
+| ETuple e -> pp_tuple_expr e
+| EPar e -> pp_par pp_expr e
+| EFun e -> pp_fun_expr e
+
+and pp_annot_expr {value; _} = string "TODO:pp_annot_expr"
+
+and pp_set_expr = function
+ SetInj inj -> string "TODO:pp_set_expr:SetInj"
+| SetMem mem -> string "TODO:pp_set_expr:SetMem"
+
+and pp_map_expr = function
+ MapLookUp fetch -> pp_map_lookup fetch
+| MapInj inj -> pp_injection pp_binding inj
+| BigMapInj inj -> pp_injection pp_binding inj
+
+and pp_map_lookup {value; _} = string "TODO:pp_map_lookup"
+
+and pp_path = function
+ Name v -> pp_ident v
+| Path p -> pp_projection p
+
+and pp_logic_expr = function
+ BoolExpr e -> pp_bool_expr e
+| CompExpr e -> pp_comp_expr e
+
+and pp_bool_expr = function
+ Or e -> pp_bin_op "||" e
+| And e -> pp_bin_op "&&" e
+| Not e -> pp_un_op "not" e
+| True _ -> string "true"
+| False _ -> string "false"
+
+and pp_bin_op op {value; _} =
+ let {arg1; arg2; _} = value
+ and length = String.length op + 1 in
+ pp_expr arg1 ^/^ string (op ^ " ") ^^ nest length (pp_expr arg2)
+
+and pp_un_op op {value; _} =
+ string (op ^ " ") ^^ pp_expr value.arg
+
+and pp_comp_expr = function
+ Lt e -> pp_bin_op "<" e
+| Leq e -> pp_bin_op "<=" e
+| Gt e -> pp_bin_op ">" e
+| Geq e -> pp_bin_op ">=" e
+| Equal e -> pp_bin_op "=" e
+| Neq e -> pp_bin_op "<>" e
+
+and pp_arith_expr = function
+ Add e -> pp_bin_op "+" e
+| Sub e -> pp_bin_op "-" e
+| Mult e -> pp_bin_op "*" e
+| Div e -> pp_bin_op "/" e
+| Mod e -> pp_bin_op "mod" e
+| Neg e -> string "-" ^^ pp_expr e.value.arg
+| Int e -> pp_int e
+| Nat e -> pp_nat e
+| Mutez e -> pp_mutez e
+
+and pp_mutez {value; _} =
+ Z.to_string (snd value) ^ "mutez" |> string
+
+and pp_string_expr = function
+ Cat e -> pp_bin_op "^" e
+| String e -> pp_string e
+| Verbatim e -> pp_verbatim e
+
+and pp_ident {value; _} = string value
+
+and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
+
+and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
+
+and pp_list_expr = function
+ ECons e -> pp_bin_op "#" e
+| EListComp e -> group (pp_injection pp_expr e)
+| ENil _ -> string "nil"
+
+and pp_constr_expr = function
+ SomeApp a -> pp_some_app a
+| NoneExpr _ -> string "None"
+| ConstrApp a -> pp_constr_app a
+
+and pp_some_app {value; _} = string "TODO:pp_some_app"
+
+and pp_constr_app {value; _} = string "TODO:pp_constr_app"
+
+and pp_field_assign {value; _} = string "TODO:pp_field_assign"
+
+and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
+
+and pp_projection {value; _} = string "TODO:pp_projection"
+
+and pp_update {value; _} = string "TODO:pp_update"
+
+and pp_field_path_assign {value; _} = string "TODO:pp_field_path_assign"
+
+and pp_selection = function
+ FieldName _ -> string "TODO:pp_selection:FieldName"
+| Component cmp -> cmp.value |> snd |> Z.to_string |> string
+
+and pp_tuple_expr {value; _} =
+ let head, tail = value.inside in
+ let rec app = function
+ [] -> empty
+ | [e] -> group (break 1 ^^ pp_expr e)
+ | e::items ->
+ group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items in
+ let components =
+ if tail = []
+ then pp_expr head
+ else pp_expr head ^^ string "," ^^ app (List.map snd tail)
+ in string "(" ^^ nest 1 (components ^^ string ")")
+
+and pp_fun_call {value; _} =
+ let lambda, arguments = value in
+ let arguments = pp_tuple_expr arguments in
+ group (pp_expr lambda ^^ nest 2 (break 1 ^^ arguments))
+
+and pp_arguments v = pp_tuple_expr v
+
+(* Injections *)
+
+and pp_injection :
+ 'a.('a -> document) -> 'a injection reg -> document =
+ fun printer {value; _} -> string "TODO:pp_injection"
+
+and pp_ne_injection :
+ 'a.('a -> document) -> 'a ne_injection reg -> document =
+ fun printer {value; _} ->
+ let {kind; enclosing; ne_elements; _} = value in
+ let elements = pp_nsepseq ";" printer ne_elements in
+ let kwd = pp_ne_injection_kwd kind in
+ let offset = String.length kwd + 2 in
+ string (kwd ^ " [")
+ ^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
+
+and pp_ne_injection_kwd = function
+ NEInjAttr _ -> "attributes"
+| NEInjSet _ -> "set"
+| NEInjMap _ -> "map"
+| NEInjRecord _ -> "record"
+
+and pp_nsepseq :
+ 'a.string ->
+ ('a -> document) ->
+ ('a, t) Utils.nsepseq ->
+ document =
+ fun sep printer elements ->
+ let elems = Utils.nsepseq_to_list elements
+ and sep = string sep ^^ break 1
+ in separate_map sep printer elems
+
+(* Patterns *)
+
+and pp_pattern = function
+ PConstr p -> pp_constr_pattern p
+| PVar v -> pp_ident v
+| PWild _ -> string "_"
+| PInt i -> pp_int i
+| PNat n -> pp_nat n
+| PBytes b -> pp_bytes b
+| PString s -> pp_string s
+| PList l -> pp_list_pattern l
+| PTuple t -> pp_tuple_pattern t
+
+and pp_int {value; _} =
+ string (Z.to_string (snd value))
+
+and pp_nat {value; _} =
+ string (Z.to_string (snd value) ^ "n")
+
+and pp_bytes {value; _} =
+ string ("0x" ^ Hex.show (snd value))
+
+and pp_constr_pattern = function
+ PUnit _ -> string "Unit"
+| PFalse _ -> string "False"
+| PTrue _ -> string "True"
+| PNone _ -> string "None"
+| PSomeApp a -> pp_psome a
+| PConstrApp a -> pp_pconstr_app a
+
+and pp_psome {value=_, p; _} =
+ prefix 4 1 (string "Some") (pp_par pp_pattern p)
+
+and pp_pconstr_app {value; _} = string "TODO:pp_pconstr_app"
+
+and pp_tuple_pattern {value; _} = string "TODO:tuple_pattern"
+
+and pp_list_pattern = function
+ PListComp cmp -> pp_list_comp cmp
+| PNil _ -> string "nil"
+| PParCons p -> pp_ppar_cons p
+| PCons p -> pp_nsepseq "#" pp_pattern p.value
+
+and pp_list_comp {value; _} = string "TODO:pp_list_comp"
+
+and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons"
+
+and pp_cons {value; _} = string "TODO:pp_cons"
diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml
index 64a8eea52..3fc439efb 100644
--- a/src/passes/1-parser/pascaligo/Scoping.ml
+++ b/src/passes/1-parser/pascaligo/Scoping.ml
@@ -23,7 +23,7 @@ module Ord =
struct
type t = AST.variable
let compare v1 v2 =
- compare v1.value v2.value
+ String.compare v1.value v2.value
end
module VarSet = Set.Make (Ord)
diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune
index ca4865ae9..5b2f099ca 100644
--- a/src/passes/1-parser/pascaligo/dune
+++ b/src/passes/1-parser/pascaligo/dune
@@ -15,8 +15,10 @@
(name parser_pascaligo)
(public_name ligo.parser.pascaligo)
(modules
- Scoping AST pascaligo Parser ParserLog LexToken ParErr)
+ Scoping AST pascaligo Parser ParserLog LexToken ParErr Pretty)
(libraries
+ pprint
+ terminal_size
menhirLib
parser_shared
hex
diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml
index ff353412a..dea9eb5a8 100644
--- a/src/passes/1-parser/reasonligo.ml
+++ b/src/passes/1-parser/reasonligo.ml
@@ -189,7 +189,7 @@ let pretty_print source =
match parse_file source with
Stdlib.Error _ as e -> e
| Ok ast ->
- let doc = Pretty.make (fst ast) in
+ let doc = Pretty.print (fst ast) in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with
diff --git a/src/passes/1-parser/reasonligo/Pretty.ml b/src/passes/1-parser/reasonligo/Pretty.ml
index ab0a3402d..c4cec4c65 100644
--- a/src/passes/1-parser/reasonligo/Pretty.ml
+++ b/src/passes/1-parser/reasonligo/Pretty.ml
@@ -7,7 +7,7 @@ open! PPrint
(*let paragraph (s : string) = flow (break 1) (words s)*)
-let rec make ast =
+let rec print ast =
let app decl = group (pp_declaration decl) in
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml
index c76b464f7..31867602b 100644
--- a/src/passes/10-interpreter/interpreter.ml
+++ b/src/passes/10-interpreter/interpreter.ml
@@ -368,19 +368,23 @@ and eval : Ast_typed.expression -> env -> value result
let dummy : Ast_typed.program -> string result =
fun prg ->
- let%bind (res,_) = bind_fold_list
- (fun (pp,top_env) el ->
- let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in
- let%bind v =
- (*TODO This TRY-CATCH is here until we properly implement effects*)
- try
- eval expr top_env
- with Temporary_hack s -> ok @@ V_Failure s
- (*TODO This TRY-CATCH is here until we properly implement effects*)
- in
- let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
- let top_env' = Env.extend top_env (binder, v) in
- ok @@ (pp',top_env')
- )
+ let aux (pp,top_env) el =
+ match Location.unwrap el with
+ | Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _} ->
+ let%bind v =
+ (*TODO This TRY-CATCH is here until we properly implement effects*)
+ try
+ eval expr top_env
+ with Temporary_hack s ->
+ ok (V_Failure s)
+ (*TODO This TRY-CATCH is here until we properly implement effects*)
+ in
+ let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
+ let top_env' = Env.extend top_env (binder, v) in
+ ok @@ (pp',top_env')
+ | Ast_typed.Declaration_type _ ->
+ ok (pp , top_env)
+ in
+ let%bind (res,_) = bind_fold_list aux
("",Env.empty_env) prg in
ok @@ res
diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml
index 9c1973f0d..5ea4ea43f 100644
--- a/src/passes/10-transpiler/transpiler.ml
+++ b/src/passes/10-transpiler/transpiler.ml
@@ -42,14 +42,6 @@ them. please report this to the developers." in
] in
error ~data title content
- let unsupported_iterator location =
- let title () = "unsupported iterator" in
- let content () = "only lambda are supported as iterators" in
- let data = [
- row_loc location ;
- ] in
- error ~data title content
-
let not_functional_main location =
let title () = "not functional main" in
let content () = "main should be a function" in
@@ -382,9 +374,6 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_unit -> D_unit
| Literal_void -> D_none
-and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele ->
- transpile_type ele.type_value
-
and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t ->
let%bind map_tv = get_t_sum t in
let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in
@@ -405,11 +394,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> (
- let%bind ele =
- trace_option (corner_case ~loc:__LOC__ "name not in environment") @@
- AST.Environment.get_opt name ae.environment in
- let%bind tv = transpile_environment_element_type ele in
- return ~tv @@ E_variable (name)
+ return @@ E_variable (name)
)
| E_application {lamb; args} ->
let%bind a = transpile_annotated_expression lamb in
@@ -449,7 +434,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return ~tv ae
)
| E_record m -> (
- (*list_of_lmap to record_to_list*)
let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in
let aux a b : expression result =
let%bind a = a in
@@ -511,28 +495,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return @@ E_record_update (record, path, update)
| E_constant {cons_name=name; arguments=lst} -> (
let iterator_generator iterator_name =
- let lambda_to_iterator_body (f : AST.expression) (l : AST.lambda) =
- let%bind body' = transpile_annotated_expression l.result in
- let%bind (input , _) = AST.get_t_function f.type_expression in
- let%bind input' = transpile_type input in
- ok ((l.binder , input') , body')
- in
let expression_to_iterator_body (f : AST.expression) =
- match f.expression_content with
- | E_lambda l -> lambda_to_iterator_body f l
- | E_variable v -> (
- let%bind elt =
- trace_option (corner_case ~loc:__LOC__ "missing var") @@
- AST.Environment.get_opt v f.environment in
- match elt.definition with
- | ED_declaration { expr = f ; free_variables = _ } -> (
- match f.expression_content with
- | E_lambda l -> lambda_to_iterator_body f l
- | _ -> fail @@ unsupported_iterator f.location
- )
- | _ -> fail @@ unsupported_iterator f.location
- )
- | _ -> fail @@ unsupported_iterator f.location
+ let%bind (input , output) = AST.get_t_function f.type_expression in
+ let%bind f' = transpile_annotated_expression f in
+ let%bind input' = transpile_type input in
+ let%bind output' = transpile_type output in
+ let binder = Var.fresh ~name:"iterated" () in
+ let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in
+ ok ((binder , input'), application)
in
fun (lst : AST.expression list) -> match (lst , iterator_name) with
| [f ; i] , C_ITER | [f ; i] , C_MAP -> (
@@ -781,25 +751,29 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in
ok @@ Expression.make (E_closure {binder;body}) fun_type
-let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
+let transpile_declaration env (d:AST.declaration) : toplevel_statement option result =
match d with
- | Declaration_constant { binder ; expr ; inline ; post_env=_ } ->
+ | Declaration_constant { binder ; expr ; inline } ->
let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (binder, tv) env in
- ok @@ ((binder, inline, expression), environment_wrap env env')
+ ok @@ Some ((binder, inline, expression), environment_wrap env env')
+ | _ -> ok None
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =
let%bind (hds, env) = prev in
- let%bind ((_, env') as cur') = transpile_declaration env cur in
- ok (hds @ [ cur' ], env'.post_environment)
+ match%bind transpile_declaration env cur with
+ | Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment)
+ | None -> ok (hds , env)
in
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements
(* check whether the storage contains a big_map, if yes, check that
- it appears on the left hand side of a pair *)
+ it appears on the left hand side of a pair
+ TODO : checking should appears in check_pass.
+*)
let check_storage f ty loc : (anon_function * _) result =
let rec aux (t:type_expression) on_big_map =
match t.type_content with
diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml
index a6864bff9..5f68cddd5 100644
--- a/src/passes/10-transpiler/untranspiler.ml
+++ b/src/passes/10-transpiler/untranspiler.ml
@@ -42,19 +42,19 @@ open Errors
let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
let open! AST in
- let return e = ok (make_a_e_empty e t) in
+ let return e = ok (make_e e t) in
match t.type_content with
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
- return (e_bool b Environment.empty)
+ return (e_bool b)
)
| t when (compare t (t_bool ()).type_content) = 0-> (
let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in
- return (e_bool b Environment.empty)
+ return (e_bool b)
)
| T_constant type_constant -> (
match type_constant with
@@ -152,10 +152,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
trace_strong (wrong_mini_c_value "option" v) @@
get_option v in
match opt with
- | None -> ok (e_a_empty_none o)
+ | None -> ok (e_a_none o)
| Some s ->
let%bind s' = untranspile s o in
- ok (e_a_empty_some s')
+ ok (e_a_some s')
)
| TC_map {k=k_ty;v=v_ty}-> (
let%bind map =
diff --git a/src/passes/13-self_michelson/self_michelson.ml b/src/passes/13-self_michelson/self_michelson.ml
index 8a3291204..729bd454a 100644
--- a/src/passes/13-self_michelson/self_michelson.ml
+++ b/src/passes/13-self_michelson/self_michelson.ml
@@ -422,6 +422,56 @@ let rec opt_combine_drops (x : michelson) : michelson =
Prim (l, p, List.map opt_combine_drops args, annot)
| x -> x
+(* number of type arguments for (some) prims, where we will strip
+ annots *)
+let prim_type_args : prim -> int option = function
+ | I_NONE -> Some 1
+ | I_NIL -> Some 1
+ | I_EMPTY_SET -> Some 1
+ | I_EMPTY_MAP -> Some 2
+ | I_EMPTY_BIG_MAP -> Some 2
+ | I_LAMBDA -> Some 2
+ (* _not_ I_CONTRACT! annot is important there *)
+ (* but could include I_SELF, maybe? *)
+ | _ -> None
+
+(* returns (List.firstn n xs, List.skipn n xs) as in Coq (OCaml stdlib
+ does not have those...) *)
+let split_at (n : int) (xs : 'a list) : 'a list * 'a list =
+ let rec aux n acc =
+ if n <= 0
+ then acc
+ else
+ let (bef, aft) = acc in
+ match aft with
+ | [] -> acc
+ | x :: aft ->
+ aux (n - 1) (x :: bef, aft) in
+ let (bef, aft) = aux n ([], xs) in
+ (List.rev bef, aft)
+
+(* strip annots from type arguments in some instructions *)
+let rec opt_strip_annots (x : michelson) : michelson =
+ match x with
+ | Seq (l, args) ->
+ let args = List.map opt_strip_annots args in
+ Seq (l, args)
+ | Prim (l, p, args, annot) ->
+ begin
+ match prim_type_args p with
+ | Some n ->
+ let (type_args, args) = split_at n args in
+ (* strip annots from type args *)
+ let type_args = List.map strip_annots type_args in
+ (* recur into remaining args *)
+ let args = List.map opt_strip_annots args in
+ Prim (l, p, type_args @ args, annot)
+ | None ->
+ let args = List.map opt_strip_annots args in
+ Prim (l, p, args, annot)
+ end
+ | x -> x
+
let optimize : michelson -> michelson =
fun x ->
let x = use_lambda_instr x in
@@ -436,4 +486,5 @@ let optimize : michelson -> michelson =
] in
let x = iterate_optimizer (sequence_optimizers optimizers) x in
let x = opt_combine_drops x in
+ let x = opt_strip_annots x in
x
diff --git a/src/passes/8-typer-new/PP.ml b/src/passes/8-typer-new/PP.ml
index b76e55500..c5199f60d 100644
--- a/src/passes/8-typer-new/PP.ml
+++ b/src/passes/8-typer-new/PP.ml
@@ -2,7 +2,7 @@ open Ast_typed
open Format
module UF = UnionFind.Poly2
-let type_constraint_ : _ -> type_constraint_simpl_ -> unit = fun ppf ->
+let type_constraint_ : _ -> type_constraint_simpl -> unit = fun ppf ->
function
|SC_Constructor { tv; c_tag; tv_list=_ } ->
let ct = match c_tag with
@@ -34,8 +34,8 @@ let type_constraint_ : _ -> type_constraint_simpl_ -> unit = fun ppf ->
|SC_Poly _ -> fprintf ppf "Poly"
|SC_Typeclass _ -> fprintf ppf "TC"
-let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf { reason_simpl ; c_simpl } ->
- fprintf ppf "%a (reason: %s)" type_constraint_ c_simpl reason_simpl
+let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf c ->
+ fprintf ppf "%a (reason: %s)" type_constraint_ c (reason_simpl c)
let all_constraints ppf ac =
fprintf ppf "[%a]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";\n") type_constraint) ac
diff --git a/src/passes/8-typer-new/README b/src/passes/8-typer-new/README
new file mode 100644
index 000000000..a84d67214
--- /dev/null
+++ b/src/passes/8-typer-new/README
@@ -0,0 +1,31 @@
+Components:
+* assignments (passive data structure).
+ Now: just a map from unification vars to types (pb: what about partial types?)
+ maybe just local assignments (allow only vars as children of pair(α,β))
+* constraint propagation: (buch of constraints) → (new constraints * assignments)
+ * sub-component: constraint selector (worklist / dynamic queries)
+ * sub-sub component: constraint normalizer: remove dupes and give structure
+ right now: union-find of unification vars
+ later: better database-like organisation of knowledge
+ * sub-sub component: lazy selector (don't re-try all selectors every time)
+ For now: just re-try everytime
+ * sub-component: propagation rule
+ For now: break pair(a, b) = pair(c, d) into a = c, b = d
+* generalizer
+ For now: ?
+
+Workflow:
+ Start with empty assignments and structured database
+ Receive a new constraint
+ For each normalizer:
+ Use the pre-selector to see if it can be applied
+ Apply the normalizer, get some new items to insert in the structured database
+ For each propagator:
+ Use the selector to query the structured database and see if it can be applied
+ Apply the propagator, get some new constraints and assignments
+ Add the new assignments to the data structure.
+
+ At some point (when?)
+ For each generalizer:
+ Use the generalizer's selector to see if it can be applied
+ Apply the generalizer to produce a new type, possibly with some ∀s injected
diff --git a/src/passes/8-typer-new/constraint_databases.ml b/src/passes/8-typer-new/constraint_databases.ml
new file mode 100644
index 000000000..8a121e11d
--- /dev/null
+++ b/src/passes/8-typer-new/constraint_databases.ml
@@ -0,0 +1,69 @@
+module Map = RedBlackTrees.PolyMap
+module UF = UnionFind.Poly2
+open Ast_typed.Types
+
+(* Light wrapper for API for grouped_by_variable in the structured
+ db, to access it modulo unification variable aliases. *)
+let get_constraints_related_to : type_variable -> structured_dbs -> constraints =
+ fun variable dbs ->
+ let variable , aliases = UF.get_or_set variable dbs.aliases in
+ let dbs = { dbs with aliases } in
+ match Map.find_opt variable dbs.grouped_by_variable with
+ Some l -> l
+ | None -> {
+ constructor = [] ;
+ poly = [] ;
+ tc = [] ;
+ }
+let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs =
+ fun variable c dbs ->
+ (* let (variable_repr , _height) , aliases = UF.get_or_set variable dbs.aliases in
+ let dbs = { dbs with aliases } in *)
+ let variable_repr , aliases = UF.get_or_set variable dbs.aliases in
+ let dbs = { dbs with aliases } in
+ let grouped_by_variable = Map.update variable_repr (function
+ None -> Some c
+ | Some (x : constraints) -> Some {
+ constructor = c.constructor @ x.constructor ;
+ poly = c.poly @ x.poly ;
+ tc = c.tc @ x.tc ;
+ })
+ dbs.grouped_by_variable
+ in
+ let dbs = { dbs with grouped_by_variable } in
+ dbs
+
+let merge_constraints : type_variable -> type_variable -> structured_dbs -> structured_dbs =
+ fun variable_a variable_b dbs ->
+ (* get old representant for variable_a *)
+ let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in
+ let dbs = { dbs with aliases } in
+ (* get old representant for variable_b *)
+ let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in
+ let dbs = { dbs with aliases } in
+
+ (* alias variable_a and variable_b together *)
+ let aliases = UF.alias variable_a variable_b dbs.aliases in
+ let dbs = { dbs with aliases } in
+
+ (* Replace the two entries in grouped_by_variable by a single one *)
+ (
+ let get_constraints ab =
+ match Map.find_opt ab dbs.grouped_by_variable with
+ | Some x -> x
+ | None -> { constructor = [] ; poly = [] ; tc = [] } in
+ let constraints_a = get_constraints variable_repr_a in
+ let constraints_b = get_constraints variable_repr_b in
+ let all_constraints = {
+ constructor = constraints_a.constructor @ constraints_b.constructor ;
+ poly = constraints_a.poly @ constraints_b.poly ;
+ tc = constraints_a.tc @ constraints_b.tc ;
+ } in
+ let grouped_by_variable =
+ Map.add variable_repr_a all_constraints dbs.grouped_by_variable in
+ let dbs = { dbs with grouped_by_variable} in
+ let grouped_by_variable =
+ Map.remove variable_repr_b dbs.grouped_by_variable in
+ let dbs = { dbs with grouped_by_variable} in
+ dbs
+ )
diff --git a/src/passes/8-typer-new/heuristic_break_ctor.ml b/src/passes/8-typer-new/heuristic_break_ctor.ml
new file mode 100644
index 000000000..e676f2500
--- /dev/null
+++ b/src/passes/8-typer-new/heuristic_break_ctor.ml
@@ -0,0 +1,52 @@
+(* selector / propagation rule for breaking down composite types
+ * For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
+
+open Ast_typed.Misc
+open Ast_typed.Types
+open Solver_types
+
+let selector : (type_constraint_simpl, output_break_ctor) selector =
+ (* find two rules with the shape x = k(var …) and x = k'(var' …) *)
+ fun type_constraint_simpl dbs ->
+ match type_constraint_simpl with
+ SC_Constructor c ->
+ (* finding other constraints related to the same type variable and
+ with the same sort of constraint (constructor vs. constructor)
+ is symmetric *)
+ let other_cs = (Constraint_databases.get_constraints_related_to c.tv dbs).constructor in
+ let other_cs = List.filter (fun (o : c_constructor_simpl) -> Var.equal c.tv o.tv) other_cs in
+ (* TODO double-check the conditions in the propagator, we had a
+ bug here because the selector was too permissive. *)
+ let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in
+ WasSelected cs_pairs
+ | SC_Alias _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *)
+ | SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *)
+ | SC_Typeclass _ -> WasNotSelected
+
+let propagator : output_break_ctor propagator =
+ fun selected dbs ->
+ let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *)
+ let a = selected.a_k_var in
+ let b = selected.a_k'_var' in
+
+ (* The selector is expected to provice two constraints with the shape x = k(var …) and x = k'(var' …) *)
+ assert (Var.equal (a : c_constructor_simpl).tv (b : c_constructor_simpl).tv);
+
+ (* produce constraints: *)
+
+ (* a.tv = b.tv *)
+ let eq1 = c_equation { tsrc = "solver: propagator: break_ctor a" ; t = P_variable a.tv} { tsrc = "solver: propagator: break_ctor b" ; t = P_variable b.tv} "propagator: break_ctor" in
+ (* a.c_tag = b.c_tag *)
+ if (Solver_should_be_generated.compare_simple_c_constant a.c_tag b.c_tag) <> 0 then
+ failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)"
+ Solver_should_be_generated.debug_pp_c_constructor_simpl a
+ Solver_should_be_generated.debug_pp_c_constructor_simpl b
+ (Solver_should_be_generated.compare_simple_c_constant a.c_tag b.c_tag))
+ else
+ (* a.tv_list = b.tv_list *)
+ if List.length a.tv_list <> List.length b.tv_list then
+ failwith "type error: incompatible types, not same length"
+ else
+ let eqs3 = List.map2 (fun aa bb -> c_equation { tsrc = "solver: propagator: break_ctor aa" ; t = P_variable aa} { tsrc = "solver: propagator: break_ctor bb" ; t = P_variable bb} "propagator: break_ctor") a.tv_list b.tv_list in
+ let eqs = eq1 :: eqs3 in
+ (eqs , []) (* no new assignments *)
diff --git a/src/passes/8-typer-new/heuristic_specialize1.ml b/src/passes/8-typer-new/heuristic_specialize1.ml
new file mode 100644
index 000000000..6e481fc12
--- /dev/null
+++ b/src/passes/8-typer-new/heuristic_specialize1.ml
@@ -0,0 +1,53 @@
+(* selector / propagation rule for specializing polymorphic types
+ * For now: (x = forall y, z) and (x = k'(var' …))
+ * produces the new constraint (z[x |-> k'(var' …)])
+ * where [from |-> to] denotes substitution. *)
+
+module Core = Typesystem.Core
+open Ast_typed.Misc
+open Ast_typed.Types
+open Solver_types
+
+let selector : (type_constraint_simpl, output_specialize1) selector =
+ (* find two rules with the shape (x = forall b, d) and x = k'(var' …) or vice versa *)
+ (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *)
+ (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *)
+ fun type_constraint_simpl dbs ->
+ match type_constraint_simpl with
+ SC_Constructor c ->
+ (* vice versa *)
+ let other_cs = (Constraint_databases.get_constraints_related_to c.tv dbs).poly in
+ let other_cs = List.filter (fun (x : c_poly_simpl) -> Var.equal c.tv x.tv) other_cs in
+ let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in
+ WasSelected cs_pairs
+ | SC_Alias _ -> WasNotSelected (* TODO: ??? *)
+ | SC_Poly p ->
+ let other_cs = (Constraint_databases.get_constraints_related_to p.tv dbs).constructor in
+ let other_cs = List.filter (fun (x : c_constructor_simpl) -> Var.equal x.tv p.tv) other_cs in
+ let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in
+ WasSelected cs_pairs
+ | SC_Typeclass _ -> WasNotSelected
+
+let propagator : output_specialize1 propagator =
+ fun selected dbs ->
+ let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *)
+ let a = selected.poly in
+ let b = selected.a_k_var in
+
+ (* The selector is expected to provide two constraints with the shape (x = forall y, z) and x = k'(var' …) *)
+ assert (Var.equal (a : c_poly_simpl).tv (b : c_constructor_simpl).tv);
+
+ (* produce constraints: *)
+
+ (* create a fresh existential variable to instantiate the polymorphic type y *)
+ let fresh_existential = Core.fresh_type_variable () in
+ (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential])
+ The substitution is obtained by immediately applying the forall. *)
+ let apply = {
+ tsrc = "solver: propagator: specialize1 apply" ;
+ t = P_apply { tf = { tsrc = "solver: propagator: specialize1 tf" ; t = P_forall a.forall };
+ targ = { tsrc = "solver: propagator: specialize1 targ" ; t = P_variable fresh_existential }} } in
+ let (reduced, new_constraints) = Typelang.check_applied @@ Typelang.type_level_eval apply in
+ let eq1 = c_equation { tsrc = "solver: propagator: specialize1 eq1" ; t = P_variable b.tv } reduced "propagator: specialize1" in
+ let eqs = eq1 :: new_constraints in
+ (eqs, []) (* no new assignments *)
diff --git a/src/passes/8-typer-new/normalizer.ml b/src/passes/8-typer-new/normalizer.ml
new file mode 100644
index 000000000..8c391c2d5
--- /dev/null
+++ b/src/passes/8-typer-new/normalizer.ml
@@ -0,0 +1,126 @@
+module Core = Typesystem.Core
+module Map = RedBlackTrees.PolyMap
+open Ast_typed.Misc
+open Ast_typed.Types
+open Solver_types
+
+(* sub-sub component: constraint normalizer: remove dupes and give structure
+ * right now: union-find of unification vars
+ * later: better database-like organisation of knowledge *)
+
+(* Each normalizer returns an updated database (after storing the
+ incoming constraint) and a list of constraints, used when the
+ normalizer rewrites the constraints e.g. into simpler ones. *)
+(* TODO: If implemented in a language with decent sets, should be 'b set not 'b list. *)
+type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list)
+
+(** Updates the dbs.all_constraints field when new constraints are
+ discovered.
+
+ This field contains a list of all the constraints, without any form of
+ grouping or sorting. *)
+let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer =
+ fun dbs new_constraint ->
+ ({ dbs with all_constraints = new_constraint :: dbs.all_constraints } , [new_constraint])
+
+(** Updates the dbs.grouped_by_variable field when new constraints are
+ discovered.
+
+ This field contains a map from type variables to lists of
+ constraints that are related to that variable (in other words, the
+ key appears in the equation).
+ *)
+let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer =
+ fun dbs new_constraint ->
+ let store_constraint tvars constraints =
+ let aux dbs (tvar : type_variable) =
+ Constraint_databases.add_constraints_related_to tvar constraints dbs
+ in List.fold_left aux dbs tvars
+ in
+ let dbs = match new_constraint with
+ SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []}
+ | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]}
+ | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []}
+ | SC_Alias { a; b } -> Constraint_databases.merge_constraints a b dbs
+ in (dbs , [new_constraint])
+
+(** Stores the first assinment ('a = ctor('b, …)) that is encountered.
+
+ Subsequent ('a = ctor('b2, …)) with the same 'a are ignored.
+
+ TOOD: are we checking somewhere that 'b … = 'b2 … ? *)
+let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer =
+ fun dbs new_constraint ->
+ match new_constraint with
+ | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) ->
+ let assignments = Map.update tv (function None -> Some c | e -> e) dbs.assignments in
+ let dbs = {dbs with assignments} in
+ (dbs , [new_constraint])
+ | _ ->
+ (dbs , [new_constraint])
+
+(* TODO: at some point there may be uses of named type aliases (type
+ foo = int; let x : foo = 42). These should be inlined. *)
+
+(** This function converts constraints from type_constraint to
+ type_constraint_simpl. The former has more possible cases, and the
+ latter uses a more minimalistic constraint language.
+
+ It does not modify the dbs, and only rewrites the constraint
+
+ TODO: update the code to show that the dbs are always copied as-is
+ *)
+let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer =
+ fun dbs new_constraint ->
+ let insert_fresh a b =
+ let fresh = Core.fresh_type_variable () in
+ let (dbs , cs1) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 1" ; t = P_variable fresh } a "normalizer: simpl 1") in
+ let (dbs , cs2) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 2" ; t = P_variable fresh } b "normalizer: simpl 2") in
+ (dbs , cs1 @ cs2) in
+ let split_constant a c_tag args =
+ let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in
+ let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split_constant" ; t = P_variable v } t "normalizer: split_constant") (List.combine fresh_vars args) in
+ let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in
+ (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars;reason_constr_simpl=Format.asprintf "normalizer: split constant %a = %a (%a)" Var.pp a Ast_typed.PP_generic.constant_tag c_tag (PP_helpers.list_sep Ast_typed.PP_generic.type_value (fun ppf () -> Format.fprintf ppf ", ")) args}] @ List.flatten recur) in
+ let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall ; reason_poly_simpl="normalizer: gather_forall"}]) in
+ let gather_alias a b = (dbs , [SC_Alias { a ; b ; reason_alias_simpl="normalizer: gather_alias"}]) in
+ let reduce_type_app a b =
+ let (reduced, new_constraints) = Typelang.check_applied @@ Typelang.type_level_eval b in
+ let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in
+ let (dbs , resimpl) = normalizer_simpl dbs (c_equation a reduced "normalizer: reduce_type_app") in (* Note: this calls recursively but cant't fall in the same case. *)
+ (dbs , resimpl @ List.flatten recur) in
+ let split_typeclass args tc =
+ let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in
+ let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split typeclass" ; t = P_variable v} t "normalizer: split_typeclass") (List.combine fresh_vars args) in
+ let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in
+ (dbs, [SC_Typeclass { tc ; args = fresh_vars ; reason_typeclass_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in
+
+ match new_constraint.c with
+ (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *)
+ | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b
+ (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *)
+ | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b
+ (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *)
+ | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b
+ (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *)
+ | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b
+ | C_equation {aval={ tsrc = _ ; t = P_forall forall }; bval={ tsrc = _ ; t = P_variable b }} -> gather_forall b forall
+ | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_forall forall }} -> gather_forall a forall
+ | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_variable b }} -> gather_alias a b
+ | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_constant { p_ctor_tag; p_ctor_args } }} -> split_constant a p_ctor_tag p_ctor_args
+ | C_equation {aval={ tsrc = _ ; t = P_constant {p_ctor_tag; p_ctor_args} }; bval={ tsrc = _ ; t = P_variable b }} -> split_constant b p_ctor_tag p_ctor_args
+ (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *)
+ | C_equation {aval=(_ as a); bval=({ tsrc = _ ; t = P_apply _ } as b)} -> reduce_type_app a b
+ | C_equation {aval=({ tsrc = _ ; t = P_apply _ } as a); bval=(_ as b)} -> reduce_type_app b a
+ (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *)
+ | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass
+ | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *)
+
+let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad =
+ fun new_constraint dbs ->
+ (fun x -> x)
+ @@ lift normalizer_grouped_by_variable
+ @@ lift normalizer_assignments
+ @@ lift normalizer_all_constraints
+ @@ lift normalizer_simpl
+ @@ lift_state_list_monad ~state:dbs ~list:[new_constraint]
diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml
index 02ee01b7e..0bcbe1260 100644
--- a/src/passes/8-typer-new/solver.ml
+++ b/src/passes/8-typer-new/solver.ml
@@ -1,633 +1,35 @@
open Trace
-
module Core = Typesystem.Core
module Map = RedBlackTrees.PolyMap
module Set = RedBlackTrees.PolySet
module UF = UnionFind.Poly2
-
-module Wrap = Wrap
-open Wrap
-open Ast_typed.Misc
-
-(* TODO: remove this, it's not used anymore *)
-module TypeVariable =
-struct
- type t = Core.type_variable
- let compare a b = Var.compare a b
- let to_string = (fun s -> Format.asprintf "%a" Var.pp s)
-
-end
-
-
-
-(*
-
-Components:
-* assignments (passive data structure).
- Now: just a map from unification vars to types (pb: what about partial types?)
- maybe just local assignments (allow only vars as children of pair(α,β))
-* constraint propagation: (buch of constraints) → (new constraints * assignments)
- * sub-component: constraint selector (worklist / dynamic queries)
- * sub-sub component: constraint normalizer: remove dupes and give structure
- right now: union-find of unification vars
- later: better database-like organisation of knowledge
- * sub-sub component: lazy selector (don't re-try all selectors every time)
- For now: just re-try everytime
- * sub-component: propagation rule
- For now: break pair(a, b) = pair(c, d) into a = c, b = d
-* generalizer
- For now: ?
-
-Workflow:
- Start with empty assignments and structured database
- Receive a new constraint
- For each normalizer:
- Use the pre-selector to see if it can be applied
- Apply the normalizer, get some new items to insert in the structured database
- For each propagator:
- Use the selector to query the structured database and see if it can be applied
- Apply the propagator, get some new constraints and assignments
- Add the new assignments to the data structure.
-
- At some point (when?)
- For each generalizer:
- Use the generalizer's selector to see if it can be applied
- Apply the generalizer to produce a new type, possibly with some ∀s injected
-
-*)
-
open Ast_typed.Types
-
-module UnionFindWrapper = struct
- (* Light wrapper for API for grouped_by_variable in the structured
- db, to access it modulo unification variable aliases. *)
- let get_constraints_related_to : type_variable -> structured_dbs -> constraints =
- fun variable dbs ->
- let variable , aliases = UF.get_or_set variable dbs.aliases in
- let dbs = { dbs with aliases } in
- match Map.find_opt variable dbs.grouped_by_variable with
- Some l -> l
- | None -> {
- constructor = [] ;
- poly = [] ;
- tc = [] ;
- }
- let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs =
- fun variable c dbs ->
- (* let (variable_repr , _height) , aliases = UF.get_or_set variable dbs.aliases in
- let dbs = { dbs with aliases } in *)
- let variable_repr , aliases = UF.get_or_set variable dbs.aliases in
- let dbs = { dbs with aliases } in
- let grouped_by_variable = Map.update variable_repr (function
- None -> Some c
- | Some (x : constraints) -> Some {
- constructor = c.constructor @ x.constructor ;
- poly = c.poly @ x.poly ;
- tc = c.tc @ x.tc ;
- })
- dbs.grouped_by_variable
- in
- let dbs = { dbs with grouped_by_variable } in
- dbs
-
- let merge_constraints : type_variable -> type_variable -> structured_dbs -> structured_dbs =
- fun variable_a variable_b dbs ->
- (* get old representant for variable_a *)
- let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in
- let dbs = { dbs with aliases } in
- (* get old representant for variable_b *)
- let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in
- let dbs = { dbs with aliases } in
-
- (* alias variable_a and variable_b together *)
- let aliases = UF.alias variable_a variable_b dbs.aliases in
- let dbs = { dbs with aliases } in
-
- (* Replace the two entries in grouped_by_variable by a single one *)
- (
- let get_constraints ab =
- match Map.find_opt ab dbs.grouped_by_variable with
- | Some x -> x
- | None -> { constructor = [] ; poly = [] ; tc = [] } in
- let constraints_a = get_constraints variable_repr_a in
- let constraints_b = get_constraints variable_repr_b in
- let all_constraints = {
- constructor = constraints_a.constructor @ constraints_b.constructor ;
- poly = constraints_a.poly @ constraints_b.poly ;
- tc = constraints_a.tc @ constraints_b.tc ;
- } in
- let grouped_by_variable =
- Map.add variable_repr_a all_constraints dbs.grouped_by_variable in
- let dbs = { dbs with grouped_by_variable} in
- let grouped_by_variable =
- Map.remove variable_repr_b dbs.grouped_by_variable in
- let dbs = { dbs with grouped_by_variable} in
- dbs
- )
-end
-
-(* sub-sub component: constraint normalizer: remove dupes and give structure
- * right now: union-find of unification vars
- * later: better database-like organisation of knowledge *)
-
-(* Each normalizer returns an updated database (after storing the
- incoming constraint) and a list of constraints, used when the
- normalizer rewrites the constraints e.g. into simpler ones. *)
-(* TODO: If implemented in a language with decent sets, should be 'b set not 'b list. *)
-type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list)
-
-(** Updates the dbs.all_constraints field when new constraints are
- discovered.
-
- This field contains a list of all the constraints, without any form of
- grouping or sorting. *)
-let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer =
- fun dbs new_constraint ->
- ({ dbs with all_constraints = new_constraint :: dbs.all_constraints } , [new_constraint])
-
-(** Updates the dbs.grouped_by_variable field when new constraints are
- discovered.
-
- This field contains a map from type variables to lists of
- constraints that are related to that variable (in other words, the
- key appears in the equation).
- *)
-let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer =
- fun dbs new_constraint ->
- let store_constraint tvars constraints =
- let aux dbs (tvar : type_variable) =
- UnionFindWrapper.add_constraints_related_to tvar constraints dbs
- in List.fold_left aux dbs tvars
- in
- let dbs = match new_constraint.c_simpl with
- SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []}
- | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]}
- | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []}
- | SC_Alias { a; b } -> UnionFindWrapper.merge_constraints a b dbs
- in (dbs , [new_constraint])
-
-(** Stores the first assinment ('a = ctor('b, …)) that is encountered.
-
- Subsequent ('a = ctor('b2, …)) with the same 'a are ignored.
-
- TOOD: are we checking somewhere that 'b … = 'b2 … ? *)
-let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer =
- fun dbs new_constraint ->
- match new_constraint.c_simpl with
- | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) ->
- let assignments = Map.update tv (function None -> Some c | e -> e) dbs.assignments in
- let dbs = {dbs with assignments} in
- (dbs , [new_constraint])
- | _ ->
- (dbs , [new_constraint])
-
-(** Evaluates a type-leval application. For now, only supports
- immediate beta-reduction at the root of the type. *)
-let type_level_eval : type_value -> type_value * type_constraint list =
- fun tv -> Typesystem.Misc.Substitution.Pattern.eval_beta_root ~tv
-
-(** Checks that a type-level application has been fully reduced. For
- now, only some simple cases like applications of `forall`
- failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *)
- | _ -> ()
- in x
-
-(* TODO: at some point there may be uses of named type aliases (type
- foo = int; let x : foo = 42). These should be inlined. *)
-
-(** This function converts constraints from type_constraint to
- type_constraint_simpl. The former has more possible cases, and the
- latter uses a more minimalistic constraint language.
-
- It does not modify the dbs, and only rewrites the constraint
-
- TODO: update the code to show that the dbs are always copied as-is
- *)
-let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer =
- fun dbs new_constraint ->
- let insert_fresh a b =
- let fresh = Core.fresh_type_variable () in
- let (dbs , cs1) = normalizer_simpl dbs (c_equation (P_variable fresh) a "normalizer: simpl") in
- let (dbs , cs2) = normalizer_simpl dbs (c_equation (P_variable fresh) b "normalizer: simpl") in
- (dbs , cs1 @ cs2) in
- let split_constant a c_tag args =
- let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in
- let fresh_eqns = List.map (fun (v,t) -> c_equation (P_variable v) t "normalizer: split_constant") (List.combine fresh_vars args) in
- let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in
- (dbs , [{c_simpl=SC_Constructor {tv=a;c_tag;tv_list=fresh_vars};reason_simpl="normalizer: split constant"}] @ List.flatten recur) in
- let gather_forall a forall = (dbs , [{c_simpl=SC_Poly { tv=a; forall };reason_simpl="normalizer: gather_forall"}]) in
- let gather_alias a b = (dbs , [{c_simpl=SC_Alias { a ; b };reason_simpl="normalizer: gather_alias"}]) in
- let reduce_type_app a b =
- let (reduced, new_constraints) = check_applied @@ type_level_eval b in
- let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in
- let (dbs , resimpl) = normalizer_simpl dbs (c_equation a reduced "normalizer: reduce_type_app") in (* Note: this calls recursively but cant't fall in the same case. *)
- (dbs , resimpl @ List.flatten recur) in
- let split_typeclass args tc =
- let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in
- let fresh_eqns = List.map (fun (v,t) -> c_equation (P_variable v) t "normalizer: split_typeclass") (List.combine fresh_vars args) in
- let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in
- (dbs, [{c_simpl=SC_Typeclass { tc ; args = fresh_vars };reason_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in
-
- match new_constraint.c with
- (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *)
- | C_equation {aval=(P_forall _ as a); bval=(P_forall _ as b)} -> insert_fresh a b
- (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *)
- | C_equation {aval=(P_forall _ as a); bval=(P_constant _ as b)} -> insert_fresh a b
- (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *)
- | C_equation {aval=(P_constant _ as a); bval=(P_constant _ as b)} -> insert_fresh a b
- (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *)
- | C_equation {aval=(P_constant _ as a); bval=(P_forall _ as b)} -> insert_fresh a b
- | C_equation {aval=(P_forall forall); bval=(P_variable b)} -> gather_forall b forall
- | C_equation {aval=P_variable a; bval=P_forall forall} -> gather_forall a forall
- | C_equation {aval=P_variable a; bval=P_variable b} -> gather_alias a b
- | C_equation {aval=P_variable a; bval=P_constant { p_ctor_tag; p_ctor_args }} -> split_constant a p_ctor_tag p_ctor_args
- | C_equation {aval=P_constant {p_ctor_tag; p_ctor_args}; bval=P_variable b} -> split_constant b p_ctor_tag p_ctor_args
- (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *)
- | C_equation {aval=(_ as a); bval=(P_apply _ as b)} -> reduce_type_app a b
- | C_equation {aval=(P_apply _ as a); bval=(_ as b)} -> reduce_type_app b a
- (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *)
- | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass
- | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *)
-
-(* Random notes from live discussion. Kept here to include bits as a rationale later on / remind me of the discussion in the short term.
- * Feel free to erase if it rots here for too long.
- *
- * function (zetype, zevalue) { if (typeof(zevalue) != zetype) { ohlà là ; } else { return zevalue; } }
- *
- * let f = (fun {a : Type} (v : a) -> v)
- *
- * (forall 'a, 'a -> 'a) ~ (int -> int)
- * (forall {a : Type}, forall (v : a), a) ~ (forall (v : int), int)
- * ({a : Type} -> (v : a) -> a) ~ ((v : int) -> int)
- *
- * (@f int)
- *
- *
- * 'c 'c
- * 'd -> 'e && 'c ~ d && 'c ~ 'e
- * 'c -> 'c ???????????????wtf---->???????????? [ scope of 'c is fun z ]
- * 'tid ~ (forall 'c, 'c -> 'c)
- * let id = (fun z -> z) in
- * let ii = (fun z -> z + 0) : (int -> int) in
- *
- * 'a 'b ['a ~ 'b] 'a 'b
- * 'a 'a 'a 'a 'a
- * (forall 'a, 'a -> 'a -> 'a ) 'tid 'tid
- *
- * 'tid -> 'tid -> 'tid
- *
- * (forall 'a, 'a -> 'a -> 'a ) (forall 'c1, 'c1 -> 'c1) (int -> int)
- * (forall 'c1, 'c1 -> 'c1)~(int -> int)
- * ('c1 -> 'c1) ~ (int -> int)
- * (fun x y -> if random then x else y) id ii as toto
- * id "foo" *)
-
-type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list }
-let lift_state_list_monad ~state ~list = { state ; list }
-let lift f =
- fun { state ; list } ->
- let (new_state , new_lists) = List.fold_map_acc f state list in
- { state = new_state ; list = List.flatten new_lists }
-
-(* TODO: move this to the List module *)
-let named_fold_left f ~acc ~lst = List.fold_left (fun acc elt -> f ~acc ~elt) acc lst
-
-module Fun = struct let id x = x end (* in stdlib as of 4.08, we're in 4.07 for now *)
-
-let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad =
- fun new_constraint dbs ->
- Fun.id
- @@ lift normalizer_grouped_by_variable
- @@ lift normalizer_assignments
- @@ lift normalizer_all_constraints
- @@ lift normalizer_simpl
- @@ lift_state_list_monad ~state:dbs ~list:[new_constraint]
+open Solver_types
(* sub-sub component: lazy selector (don't re-try all selectors every time)
* For now: just re-try everytime *)
-type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *)
-type 'selector_output selector_outputs =
- WasSelected of 'selector_output list
- | WasNotSelected
-type new_constraints = type_constraint list
-type new_assignments = c_constructor_simpl list
-
-type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs
-type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments
-
-(* selector / propagation rule for breaking down composite types
- * For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
-
-let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector =
- (* find two rules with the shape a = k(var …) and a = k'(var' …) *)
- fun type_constraint_simpl dbs ->
- match type_constraint_simpl.c_simpl with
- SC_Constructor c ->
- (* finding other constraints related to the same type variable and
- with the same sort of constraint (constructor vs. constructor)
- is symmetric *)
- let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in
- let other_cs = List.filter (fun (o : c_constructor_simpl) -> Var.equal c.tv o.tv) other_cs in
- (* TODO double-check the conditions in the propagator, we had a
- bug here because the selector was too permissive. *)
- let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in
- WasSelected cs_pairs
- | SC_Alias _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *)
- | SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *)
- | SC_Typeclass _ -> WasNotSelected
-
-(* TODO: move this to a more appropriate place and/or auto-generate it. *)
-let compare_simple_c_constant = function
- | C_arrow -> (function
- (* N/A -> 1 *)
- | C_arrow -> 0
- | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_option -> (function
- | C_arrow -> 1
- | C_option -> 0
- | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_record -> (function
- | C_arrow | C_option -> 1
- | C_record -> 0
- | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_variant -> (function
- | C_arrow | C_option | C_record -> 1
- | C_variant -> 0
- | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_map -> (function
- | C_arrow | C_option | C_record | C_variant -> 1
- | C_map -> 0
- | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_big_map -> (function
- | C_arrow | C_option | C_record | C_variant | C_map -> 1
- | C_big_map -> 0
- | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_list -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1
- | C_list -> 0
- | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_set -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1
- | C_set -> 0
- | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_unit -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
- | C_unit -> 0
- | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_string -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
- | C_string -> 0
- | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_nat -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string -> 1
- | C_nat -> 0
- | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_mutez -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat -> 1
- | C_mutez -> 0
- | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_timestamp -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez -> 1
- | C_timestamp -> 0
- | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_int -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp -> 1
- | C_int -> 0
- | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_address -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
- | C_address -> 0
- | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_bytes -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
- | C_bytes -> 0
- | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_key_hash -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
- | C_key_hash -> 0
- | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_key -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
- | C_key -> 0
- | C_signature | C_operation | C_contract | C_chain_id -> -1)
- | C_signature -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
- | C_signature -> 0
- | C_operation | C_contract | C_chain_id -> -1)
- | C_operation -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
- | C_operation -> 0
- | C_contract | C_chain_id -> -1)
- | C_contract -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
- | C_contract -> 0
- | C_chain_id -> -1)
- | C_chain_id -> (function
- | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
- | C_chain_id -> 0
- (* N/A -> -1 *)
- )
-
-(* Using a pretty-printer from the PP.ml module creates a dependency
- loop, so the one that we need temporarily for debugging purposes
- has been copied here. *)
-let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag ->
- let ct = match c_tag with
- | T.C_arrow -> "arrow"
- | T.C_option -> "option"
- | T.C_record -> failwith "record"
- | T.C_variant -> failwith "variant"
- | T.C_map -> "map"
- | T.C_big_map -> "big_map"
- | T.C_list -> "list"
- | T.C_set -> "set"
- | T.C_unit -> "unit"
- | T.C_string -> "string"
- | T.C_nat -> "nat"
- | T.C_mutez -> "mutez"
- | T.C_timestamp -> "timestamp"
- | T.C_int -> "int"
- | T.C_address -> "address"
- | T.C_bytes -> "bytes"
- | T.C_key_hash -> "key_hash"
- | T.C_key -> "key"
- | T.C_signature -> "signature"
- | T.C_operation -> "operation"
- | T.C_contract -> "contract"
- | T.C_chain_id -> "chain_id"
- in
- Format.fprintf ppf "%s" ct
-
-let debug_pp_c_constructor_simpl ppf { tv; c_tag; tv_list } =
- Format.fprintf ppf "CTOR %a %a(%a)" Var.pp tv debug_pp_constant c_tag PP_helpers.(list_sep Var.pp (const " , ")) tv_list
-
-let propagator_break_ctor : output_break_ctor propagator =
- fun selected dbs ->
- let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *)
- let a = selected.a_k_var in
- let b = selected.a_k'_var' in
- (* produce constraints: *)
-
- (* a.tv = b.tv *)
- let eq1 = c_equation (P_variable a.tv) (P_variable b.tv) "propagator: break_ctor" in
- (* a.c_tag = b.c_tag *)
- if (compare_simple_c_constant a.c_tag b.c_tag) <> 0 then
- failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" debug_pp_c_constructor_simpl a debug_pp_c_constructor_simpl b (compare_simple_c_constant a.c_tag b.c_tag))
- else
- (* a.tv_list = b.tv_list *)
- if List.length a.tv_list <> List.length b.tv_list then
- failwith "type error: incompatible types, not same length"
- else
- let eqs3 = List.map2 (fun aa bb -> c_equation (P_variable aa) (P_variable bb) "propagator: break_ctor") a.tv_list b.tv_list in
- let eqs = eq1 :: eqs3 in
- (eqs , []) (* no new assignments *)
-
(* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-(
We need to return a lazy stream of constraints. *)
+let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments =
+ fun selector propagator ->
+ fun already_selected old_type_constraint dbs ->
+ (* TODO: thread some state to know which selector outputs were already seen *)
+ match selector old_type_constraint dbs with
+ WasSelected selected_outputs ->
+ let Set.{ set = already_selected ; duplicates = _ ; added = selected_outputs } = Set.add_list selected_outputs already_selected in
+ (* Call the propagation rule *)
+ let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in
+ let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in
+ (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *)
+ (already_selected , List.flatten new_constraints , List.flatten new_assignments)
+ | WasNotSelected ->
+ (already_selected, [] , [])
-
-let () ca cb =
- if ca = 0 then cb () else ca
-let rec compare_list f = function
- | hd1::tl1 -> (function
- [] -> 1
- | hd2::tl2 ->
- f hd1 hd2 fun () ->
- compare_list f tl1 tl2)
- | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
-let compare_type_variable a b =
- Var.compare a b
-let compare_label (a:label) (b:label) =
- let Label a = a in
- let Label b = b in
- String.compare a b
-let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b
-and compare_type_expression = function
- | P_forall { binder=a1; constraints=a2; body=a3 } -> (function
- | P_forall { binder=b1; constraints=b2; body=b3 } ->
- compare_type_variable a1 b1 fun () ->
- compare_list compare_type_constraint a2 b2 fun () ->
- compare_type_expression a3 b3
- | P_variable _ -> -1
- | P_constant _ -> -1
- | P_apply _ -> -1)
- | P_variable a -> (function
- | P_forall _ -> 1
- | P_variable b -> compare_type_variable a b
- | P_constant _ -> -1
- | P_apply _ -> -1)
- | P_constant { p_ctor_tag=a1; p_ctor_args=a2 } -> (function
- | P_forall _ -> 1
- | P_variable _ -> 1
- | P_constant { p_ctor_tag=b1; p_ctor_args=b2 } -> compare_simple_c_constant a1 b1 fun () -> compare_list compare_type_expression a2 b2
- | P_apply _ -> -1)
- | P_apply { tf=a1; targ=a2 } -> (function
- | P_forall _ -> 1
- | P_variable _ -> 1
- | P_constant _ -> 1
- | P_apply { tf=b1; targ=b2 } -> compare_type_expression a1 b1 fun () -> compare_type_expression a2 b2)
-and compare_type_constraint = fun { c = ca ; reason = ra } { c = cb ; reason = rb } ->
- let c = compare_type_constraint_ ca cb in
- if c < 0 then -1
- else if c = 0 then String.compare ra rb
- else 1
-and compare_type_constraint_ = function
- | C_equation { aval=a1; bval=a2 } -> (function
- | C_equation { aval=b1; bval=b2 } -> compare_type_expression a1 b1 fun () -> compare_type_expression a2 b2
- | C_typeclass _ -> -1
- | C_access_label _ -> -1)
- | C_typeclass { tc_args=a1; typeclass=a2 } -> (function
- | C_equation _ -> 1
- | C_typeclass { tc_args=b1; typeclass=b2 } -> compare_list compare_type_expression a1 b1 fun () -> compare_typeclass a2 b2
- | C_access_label _ -> -1)
- | C_access_label { c_access_label_tval=a1; accessor=a2; c_access_label_tvar=a3 } -> (function
- | C_equation _ -> 1
- | C_typeclass _ -> 1
- | C_access_label { c_access_label_tval=b1; accessor=b2; c_access_label_tvar=b3 } -> compare_type_expression a1 b1 fun () -> compare_label a2 b2 fun () -> compare_type_variable a3 b3)
-let compare_type_constraint_list = compare_list compare_type_constraint
-let compare_p_forall
- { binder = a1; constraints = a2; body = a3 }
- { binder = b1; constraints = b2; body = b3 } =
- compare_type_variable a1 b1 fun () ->
- compare_type_constraint_list a2 b2 fun () ->
- compare_type_expression a3 b3
-let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
- compare_type_variable a1 b1 fun () ->
- compare_p_forall a2 b2
-let compare_c_constructor_simpl { tv=a1; c_tag=a2; tv_list=a3 } { tv=b1; c_tag=b2; tv_list=b3 } =
- compare_type_variable a1 b1 fun () -> compare_simple_c_constant a2 b2 fun () -> compare_list compare_type_variable a3 b3
-
-let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } =
- compare_c_poly_simpl a1 b1 fun () ->
- compare_c_constructor_simpl a2 b2
-
-let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } =
- compare_c_constructor_simpl a1 b1 fun () -> compare_c_constructor_simpl a2 b2
-
-let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector =
- (* find two rules with the shape (a = forall b, d) and a = k'(var' …) or vice versa *)
- (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *)
- (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *)
- fun type_constraint_simpl dbs ->
- match type_constraint_simpl.c_simpl with
- SC_Constructor c ->
- (* vice versa *)
- let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in
- let other_cs = List.filter (fun (x : c_poly_simpl) -> c.tv = x.tv) other_cs in (* TODO: does equality work in OCaml? *)
- let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in
- WasSelected cs_pairs
- | SC_Alias _ -> WasNotSelected (* TODO: ??? *)
- | SC_Poly p ->
- let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in
- let other_cs = List.filter (fun (x : c_constructor_simpl) -> x.tv = p.tv) other_cs in (* TODO: does equality work in OCaml? *)
- let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in
- WasSelected cs_pairs
- | SC_Typeclass _ -> WasNotSelected
-
-let propagator_specialize1 : output_specialize1 propagator =
- fun selected dbs ->
- let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *)
- let a = selected.poly in
- let b = selected.a_k_var in
- let () = if (a.tv <> b.tv) then failwith "internal error" else () in
-
- (* produce constraints: *)
-
- (* create a fresh existential variable to instantiate the polymorphic type b *)
- let fresh_existential = Core.fresh_type_variable () in
- (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential])
- The substitution is obtained by immediately applying the forall. *)
- let apply = (P_apply {tf = (P_forall a.forall); targ = P_variable fresh_existential}) in
- let (reduced, new_constraints) = check_applied @@ type_level_eval apply in
- let eq1 = c_equation (P_variable b.tv) reduced "propagator: specialize1" in
- let eqs = eq1 :: new_constraints in
- (eqs, []) (* no new assignments *)
-
- let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments =
- let mem elt set = match RedBlackTrees.PolySet.find_opt elt set with None -> false | Some _ -> true in
- fun selector propagator ->
- fun already_selected old_type_constraint dbs ->
- (* TODO: thread some state to know which selector outputs were already seen *)
- match selector old_type_constraint dbs with
- WasSelected selected_outputs ->
- (* TODO: fold instead. *)
- let (already_selected , selected_outputs) = List.fold_left (fun (already_selected, selected_outputs) elt -> if mem elt already_selected then (RedBlackTrees.PolySet.add elt already_selected , elt :: selected_outputs)
- else (already_selected , selected_outputs)) (already_selected , selected_outputs) selected_outputs in
- (* Call the propagation rule *)
- let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in
- let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in
- (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *)
- (already_selected , List.flatten new_constraints , List.flatten new_assignments)
- | WasNotSelected ->
- (already_selected, [] , [])
-
-let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor
-let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1
+(* TODO: put the heuristics with their state in a list. *)
+let select_and_propagate_break_ctor = select_and_propagate Heuristic_break_ctor.selector Heuristic_break_ctor.propagator
+let select_and_propagate_specialize1 = select_and_propagate Heuristic_specialize1.selector Heuristic_specialize1.propagator
(* Takes a constraint, applies all selector+propagator pairs to it.
Keeps track of which constraints have already been selected. *)
@@ -660,7 +62,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
match new_constraints with
| [] -> (already_selected, dbs)
| new_constraint :: tl ->
- let { state = dbs ; list = modified_constraints } = normalizers new_constraint dbs in
+ let { state = dbs ; list = modified_constraints } = Normalizer.normalizers new_constraint dbs in
let (already_selected , new_constraints' , dbs) =
List.fold_left
(fun (already_selected , nc , dbs) c ->
@@ -675,42 +77,22 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
(* constraint propagation: (buch of constraints) → (new constraints * assignments) *)
-
-
-
-
(* Below is a draft *)
-(* type state = {
- * (\* when α-renaming x to y, we put them in the same union-find class *\)
- * unification_vars : unionfind ;
- *
- * (\* assigns a value to the representant in the unionfind *\)
- * assignments : type_expression TypeVariableMap.t ;
- *
- * (\* constraints related to a type variable *\)
- * constraints : constraints TypeVariableMap.t ;
- * } *)
-
-let initial_state : typer_state = (* {
- * unification_vars = UF.empty ;
- * constraints = TypeVariableMap.empty ;
- * assignments = TypeVariableMap.empty ;
- * } *)
-{
- structured_dbs =
- {
- all_constraints = [] ; (* type_constraint_simpl list *)
- aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare ; (* unionfind *)
- assignments = Map.create ~cmp:Var.compare; (* c_constructor_simpl TypeVariableMap.t *)
- grouped_by_variable = Map.create ~cmp:Var.compare; (* constraints TypeVariableMap.t *)
- cycle_detection_toposort = (); (* unit *)
- } ;
- already_selected = {
- break_ctor = Set.create ~cmp:compare_output_break_ctor;
- specialize1 = Set.create ~cmp:compare_output_specialize1 ;
+let initial_state : typer_state = {
+ structured_dbs =
+ {
+ all_constraints = ([] : type_constraint_simpl list) ;
+ aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare;
+ assignments = (Map.create ~cmp:Var.compare : (type_variable, c_constructor_simpl) Map.t);
+ grouped_by_variable = (Map.create ~cmp:Var.compare : (type_variable, constraints) Map.t);
+ cycle_detection_toposort = ();
+ } ;
+ already_selected = {
+ break_ctor = Set.create ~cmp:Solver_should_be_generated.compare_output_break_ctor;
+ specialize1 = Set.create ~cmp:Solver_should_be_generated.compare_output_specialize1 ;
+ }
}
-}
(* This function is called when a program is fully compiled, and the
typechecker's state is discarded. TODO: either get rid of the state
@@ -721,23 +103,6 @@ let initial_state : typer_state = (* {
state any further. Suzanne *)
let discard_state (_ : typer_state) = ()
-(* let replace_var_in_state = fun (v : type_variable) (state : state) -> *)
-(* let aux_tv : type_expression -> _ = function *)
-(* | P_forall (w , cs , tval) -> failwith "TODO" *)
-(* | P_variable (w) -> *)
-(* if w = v then *)
-(* (*…*) *)
-(* else *)
-(* (*…*) *)
-(* | P_constant (c , args) -> failwith "TODO" *)
-(* | P_access_label (tv , label) -> failwith "TODO" in *)
-(* let aux_tc tc = *)
-(* List.map (fun l -> List.map aux_tv l) tc in *)
-(* let aux : type_constraint -> _ = function *)
-(* | C_equation (l , r) -> C_equation (aux_tv l , aux_tv r) *)
-(* | C_typeclass (l , rs) -> C_typeclass (List.map aux_tv l , aux_tc rs) *)
-(* in List.map aux state *)
-
(* This is the solver *)
let aggregate_constraints : typer_state -> type_constraint list -> typer_state result = fun state newc ->
(* TODO: Iterate over constraints *)
@@ -747,12 +112,6 @@ let aggregate_constraints : typer_state -> type_constraint list -> typer_state r
(*let { constraints ; eqv } = state in
ok { constraints = constraints @ newc ; eqv }*)
-
-
-
-
-
-
(* Later on, we'll ensure that all the heuristics register the
existential/unification variables that they create, as well as the
new constraints that they create. We will then check that they only
diff --git a/src/passes/8-typer-new/solver_should_be_generated.ml b/src/passes/8-typer-new/solver_should_be_generated.ml
new file mode 100644
index 000000000..91fc93b4a
--- /dev/null
+++ b/src/passes/8-typer-new/solver_should_be_generated.ml
@@ -0,0 +1,214 @@
+(* The contents of this file should be auto-generated. *)
+
+open Ast_typed.Types
+module T = Ast_typed.Types
+
+let compare_simple_c_constant = function
+ | C_arrow -> (function
+ (* N/A -> 1 *)
+ | C_arrow -> 0
+ | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_option -> (function
+ | C_arrow -> 1
+ | C_option -> 0
+ | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_record -> (function
+ | C_arrow | C_option -> 1
+ | C_record -> 0
+ | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_variant -> (function
+ | C_arrow | C_option | C_record -> 1
+ | C_variant -> 0
+ | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_map -> (function
+ | C_arrow | C_option | C_record | C_variant -> 1
+ | C_map -> 0
+ | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_big_map -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map -> 1
+ | C_big_map -> 0
+ | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_list -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1
+ | C_list -> 0
+ | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_set -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1
+ | C_set -> 0
+ | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_unit -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1
+ | C_unit -> 0
+ | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_string -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1
+ | C_string -> 0
+ | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_nat -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string -> 1
+ | C_nat -> 0
+ | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_mutez -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat -> 1
+ | C_mutez -> 0
+ | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_timestamp -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez -> 1
+ | C_timestamp -> 0
+ | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_int -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp -> 1
+ | C_int -> 0
+ | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_address -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1
+ | C_address -> 0
+ | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_bytes -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1
+ | C_bytes -> 0
+ | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_key_hash -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1
+ | C_key_hash -> 0
+ | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_key -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1
+ | C_key -> 0
+ | C_signature | C_operation | C_contract | C_chain_id -> -1)
+ | C_signature -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1
+ | C_signature -> 0
+ | C_operation | C_contract | C_chain_id -> -1)
+ | C_operation -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1
+ | C_operation -> 0
+ | C_contract | C_chain_id -> -1)
+ | C_contract -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1
+ | C_contract -> 0
+ | C_chain_id -> -1)
+ | C_chain_id -> (function
+ | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1
+ | C_chain_id -> 0
+ (* N/A -> -1 *)
+ )
+
+let () ca cb =
+ if ca = 0 then cb () else ca
+let rec compare_list f = function
+ | hd1::tl1 -> (function
+ [] -> 1
+ | hd2::tl2 ->
+ f hd1 hd2 fun () ->
+ compare_list f tl1 tl2)
+ | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *)
+let compare_type_variable a b =
+ Var.compare a b
+let compare_label (a:label) (b:label) =
+ let Label a = a in
+ let Label b = b in
+ String.compare a b
+let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b
+and compare_type_expression { tsrc = _ ; t = ta } { tsrc = _ ; t = tb } =
+ (* Note: this comparison ignores the tsrc, the idea is that types
+ will often be compared to see if they are the same, regardless of
+ where the type comes from .*)
+ compare_type_expression_ ta tb
+and compare_type_expression_ = function
+ | P_forall { binder=a1; constraints=a2; body=a3 } -> (function
+ | P_forall { binder=b1; constraints=b2; body=b3 } ->
+ compare_type_variable a1 b1 fun () ->
+ compare_list compare_type_constraint a2 b2 fun () ->
+ compare_type_expression a3 b3
+ | P_variable _ -> -1
+ | P_constant _ -> -1
+ | P_apply _ -> -1)
+ | P_variable a -> (function
+ | P_forall _ -> 1
+ | P_variable b -> compare_type_variable a b
+ | P_constant _ -> -1
+ | P_apply _ -> -1)
+ | P_constant { p_ctor_tag=a1; p_ctor_args=a2 } -> (function
+ | P_forall _ -> 1
+ | P_variable _ -> 1
+ | P_constant { p_ctor_tag=b1; p_ctor_args=b2 } -> compare_simple_c_constant a1 b1 fun () -> compare_list compare_type_expression a2 b2
+ | P_apply _ -> -1)
+ | P_apply { tf=a1; targ=a2 } -> (function
+ | P_forall _ -> 1
+ | P_variable _ -> 1
+ | P_constant _ -> 1
+ | P_apply { tf=b1; targ=b2 } -> compare_type_expression a1 b1 fun () -> compare_type_expression a2 b2)
+and compare_type_constraint = fun { c = ca ; reason = ra } { c = cb ; reason = rb } ->
+ let c = compare_type_constraint_ ca cb in
+ if c < 0 then -1
+ else if c = 0 then String.compare ra rb
+ else 1
+and compare_type_constraint_ = function
+ | C_equation { aval=a1; bval=a2 } -> (function
+ | C_equation { aval=b1; bval=b2 } -> compare_type_expression a1 b1 fun () -> compare_type_expression a2 b2
+ | C_typeclass _ -> -1
+ | C_access_label _ -> -1)
+ | C_typeclass { tc_args=a1; typeclass=a2 } -> (function
+ | C_equation _ -> 1
+ | C_typeclass { tc_args=b1; typeclass=b2 } -> compare_list compare_type_expression a1 b1 fun () -> compare_typeclass a2 b2
+ | C_access_label _ -> -1)
+ | C_access_label { c_access_label_tval=a1; accessor=a2; c_access_label_tvar=a3 } -> (function
+ | C_equation _ -> 1
+ | C_typeclass _ -> 1
+ | C_access_label { c_access_label_tval=b1; accessor=b2; c_access_label_tvar=b3 } -> compare_type_expression a1 b1 fun () -> compare_label a2 b2 fun () -> compare_type_variable a3 b3)
+let compare_type_constraint_list = compare_list compare_type_constraint
+let compare_p_forall
+ { binder = a1; constraints = a2; body = a3 }
+ { binder = b1; constraints = b2; body = b3 } =
+ compare_type_variable a1 b1 fun () ->
+ compare_type_constraint_list a2 b2 fun () ->
+ compare_type_expression a3 b3
+let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
+ compare_type_variable a1 b1 fun () ->
+ compare_p_forall a2 b2
+let compare_c_constructor_simpl { reason_constr_simpl = _ ; tv=a1; c_tag=a2; tv_list=a3 } { reason_constr_simpl = _ ; tv=b1; c_tag=b2; tv_list=b3 } =
+ (* We do not compare the reasons, as they are only for debugging and
+ not part of the type *)
+ compare_type_variable a1 b1 fun () -> compare_simple_c_constant a2 b2 fun () -> compare_list compare_type_variable a3 b3
+
+(* TODO: use Ast_typed.Compare_generic.output_specialize1 etc. but don't compare the reasons *)
+let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } =
+ compare_c_poly_simpl a1 b1 fun () ->
+ compare_c_constructor_simpl a2 b2
+
+let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } =
+ compare_c_constructor_simpl a1 b1 fun () -> compare_c_constructor_simpl a2 b2
+
+(* Using a pretty-printer from the PP.ml module creates a dependency
+ loop, so the one that we need temporarily for debugging purposes
+ has been copied here. *)
+let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag ->
+ let ct = match c_tag with
+ | T.C_arrow -> "arrow"
+ | T.C_option -> "option"
+ | T.C_record -> failwith "record"
+ | T.C_variant -> failwith "variant"
+ | T.C_map -> "map"
+ | T.C_big_map -> "big_map"
+ | T.C_list -> "list"
+ | T.C_set -> "set"
+ | T.C_unit -> "unit"
+ | T.C_string -> "string"
+ | T.C_nat -> "nat"
+ | T.C_mutez -> "mutez"
+ | T.C_timestamp -> "timestamp"
+ | T.C_int -> "int"
+ | T.C_address -> "address"
+ | T.C_bytes -> "bytes"
+ | T.C_key_hash -> "key_hash"
+ | T.C_key -> "key"
+ | T.C_signature -> "signature"
+ | T.C_operation -> "operation"
+ | T.C_contract -> "contract"
+ | T.C_chain_id -> "chain_id"
+ in
+ Format.fprintf ppf "%s" ct
+
+let debug_pp_c_constructor_simpl ppf { tv; c_tag; tv_list } =
+ Format.fprintf ppf "CTOR %a %a(%a)" Var.pp tv debug_pp_constant c_tag PP_helpers.(list_sep Var.pp (const " , ")) tv_list
diff --git a/src/passes/8-typer-new/solver_types.ml b/src/passes/8-typer-new/solver_types.ml
new file mode 100644
index 000000000..9690d9c0a
--- /dev/null
+++ b/src/passes/8-typer-new/solver_types.ml
@@ -0,0 +1,18 @@
+open Ast_typed.Types
+
+type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *)
+type 'selector_output selector_outputs =
+ WasSelected of 'selector_output list
+ | WasNotSelected
+type new_constraints = type_constraint list
+type new_assignments = c_constructor_simpl list
+type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs
+type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments
+
+(* state+list monad *)
+type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list }
+let lift_state_list_monad ~state ~list = { state ; list }
+let lift f =
+ fun { state ; list } ->
+ let (new_state , new_lists) = List.fold_map_acc f state list in
+ { state = new_state ; list = List.flatten new_lists }
diff --git a/src/passes/8-typer-new/typelang.ml b/src/passes/8-typer-new/typelang.ml
new file mode 100644
index 000000000..ac9c3faa3
--- /dev/null
+++ b/src/passes/8-typer-new/typelang.ml
@@ -0,0 +1,18 @@
+(* This file implements the type-level language. For now limited to
+ type constants, type functions and their application. *)
+
+open Ast_typed.Types
+
+(** Evaluates a type-leval application. For now, only supports
+ immediate beta-reduction at the root of the type. *)
+let type_level_eval : type_value -> type_value * type_constraint list =
+ fun tv -> Typesystem.Misc.Substitution.Pattern.eval_beta_root ~tv
+
+(** Checks that a type-level application has been fully reduced. For
+ now, only some simple cases like applications of `forall`
+ failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *)
+ | _ -> ()
+ in x
diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml
index 36fa997fe..604740583 100644
--- a/src/passes/8-typer-new/typer.ml
+++ b/src/passes/8-typer-new/typer.ml
@@ -29,7 +29,7 @@ let rec type_declaration env state : I.declaration -> (environment * O.typer_sta
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env in
- ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline ; post_env} ))
+ ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} ))
)
and type_match : environment -> O.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O.typer_state) result =
@@ -196,7 +196,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
let%bind new_state = aggregate_constraints state constraints in
let tv = t_variable type_name () in
let location = ae.location in
- let expr' = make_e ~location expr tv e in
+ let expr' = make_e ~location expr tv in
ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error =
@@ -416,12 +416,11 @@ and type_lambda e state {
let%bind input_type' = bind_map_option (evaluate_type e) input_type in
let%bind output_type' = bind_map_option (evaluate_type e) output_type in
- let fresh : O.type_expression = t_variable (Solver.Wrap.fresh_binder ()) () in
+ let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in
let e' = Environment.add_ez_binder (binder) fresh e in
let%bind (result , state') = type_expression e' state result in
- let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in
- let wrapped = Solver.Wrap.lambda fresh input_type' output_type' in
+ let wrapped = Wrap.lambda fresh input_type' output_type' result.type_expression in
ok (({binder;result}:O.lambda),state',wrapped)
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
diff --git a/src/passes/8-typer-new/wrap.ml b/src/passes/8-typer-new/wrap.ml
index d14397b51..5c0302887 100644
--- a/src/passes/8-typer-new/wrap.ml
+++ b/src/passes/8-typer-new/wrap.ml
@@ -44,7 +44,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
| T_arrow {type1;type2} ->
p_constant C_arrow (List.map type_expression_to_type_value [ type1 ; type2 ])
- | T_variable (type_name) -> P_variable type_name
+ | T_variable (type_name) -> { tsrc = "wrap: from source code maybe?" ; t = P_variable type_name }
| T_constant (type_name) ->
let csttag = T.(match type_name with
| TC_unit -> C_unit
@@ -89,7 +89,7 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v
p_constant C_record (List.map type_expression_to_type_value_copypasted tlist)
| T_arrow {type1;type2} ->
p_constant C_arrow (List.map type_expression_to_type_value_copypasted [ type1 ; type2 ])
- | T_variable type_name -> P_variable (type_name) (* eird stuff*)
+ | T_variable type_name -> { tsrc = "wrap: from source code maybe?" ; t = P_variable type_name }
| T_constant (type_name) ->
let csttag = T.(match type_name with
| TC_unit -> C_unit
@@ -121,12 +121,12 @@ let failwith_ : unit -> (constraints * O.type_variable) = fun () ->
let variable : I.expression_variable -> T.type_expression -> (constraints * T.type_variable) = fun _name expr ->
let pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () in
- [{ c = C_equation { aval = P_variable type_name ; bval = pattern } ; reason = "wrap: variable" }] , type_name
+ [{ c = C_equation { aval = { tsrc = "wrap: variable: whole" ; t = P_variable type_name } ; bval = pattern } ; reason = "wrap: variable" }] , type_name
let literal : T.type_expression -> (constraints * T.type_variable) = fun t ->
let pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () in
- [{ c = C_equation { aval = P_variable type_name ; bval = pattern } ; reason = "wrap: literal" }] , type_name
+ [{ c = C_equation { aval = { tsrc = "wrap: literal: whole" ; t = P_variable type_name } ; bval = pattern } ; reason = "wrap: literal" }] , type_name
(*
let literal_bool : unit -> (constraints * O.type_variable) = fun () ->
@@ -144,7 +144,7 @@ let tuple : T.type_expression list -> (constraints * T.type_variable) = fun tys
let patterns = List.map type_expression_to_type_value tys in
let pattern = p_constant C_record patterns in
let type_name = Core.fresh_type_variable () in
- [{ c = C_equation { aval = P_variable type_name ; bval = pattern} ; reason = "wrap: tuple" }] , type_name
+ [{ c = C_equation { aval = { tsrc = "wrap: tuple: whole" ; t = P_variable type_name } ; bval = pattern} ; reason = "wrap: tuple" }] , type_name
(* let t_tuple = ('label:int, 'v) … -> record ('label : 'v) … *)
(* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *)
@@ -184,25 +184,25 @@ let constructor
let sum = type_expression_to_type_value sum in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation (P_variable whole_expr) sum "wrap: constructor: whole" ;
+ c_equation { tsrc = "wrap: constructor: whole" ; t = P_variable whole_expr } sum "wrap: constructor: whole" ;
c_equation t_arg c_arg "wrap: construcotr: arg" ;
] , whole_expr
let record : T.field_content T.label_map -> (constraints * T.type_variable) = fun fields ->
let record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () in
- [c_equation (P_variable whole_expr) record_type "wrap: record: whole"] , whole_expr
+ [c_equation { tsrc = "wrap: record: whole" ; t = P_variable whole_expr } record_type "wrap: record: whole"] , whole_expr
let collection : O.constant_tag -> T.type_expression list -> (constraints * T.type_variable) =
fun ctor element_tys ->
- let elttype = T.P_variable (Core.fresh_type_variable ()) in
+ let elttype = T.{ tsrc = "wrap: collection: p_variable" ; t = P_variable (Core.fresh_type_variable ()) } in
let aux elt =
let elt' = type_expression_to_type_value elt
in c_equation elttype elt' "wrap: collection: elt" in
let equations = List.map aux element_tys in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation (P_variable whole_expr) (p_constant ctor [elttype]) "wrap: collection: whole" ;
+ c_equation { tsrc = "wrap: collection: whole" ; t = P_variable whole_expr} (p_constant ctor [elttype]) "wrap: collection: whole" ;
] @ equations , whole_expr
let list = collection T.C_list
@@ -210,8 +210,8 @@ let set = collection T.C_set
let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys ->
- let k_type = T.P_variable (Core.fresh_type_variable ()) in
- let v_type = T.P_variable (Core.fresh_type_variable ()) in
+ let k_type = T.{ tsrc = "wrap: map: k" ; t = P_variable (Core.fresh_type_variable ()) } in
+ let v_type = T.{ tsrc = "wrap: map: v" ; t = P_variable (Core.fresh_type_variable ()) } in
let aux_k (k , _v) =
let k' = type_expression_to_type_value k in
c_equation k_type k' "wrap: map: key" in
@@ -222,13 +222,13 @@ let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_
let equations_v = List.map aux_v kv_tys in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation (P_variable whole_expr) (p_constant C_map [k_type ; v_type]) "wrap: map: whole" ;
+ c_equation ({ tsrc = "wrap: map: whole" ; t = P_variable whole_expr }) (p_constant C_map [k_type ; v_type]) "wrap: map: whole" ;
] @ equations_k @ equations_v , whole_expr
let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys ->
- let k_type = T.P_variable (Core.fresh_type_variable ()) in
- let v_type = T.P_variable (Core.fresh_type_variable ()) in
+ let k_type = T.{ tsrc = "wrap: big_map: k" ; t = P_variable (Core.fresh_type_variable ()) } in
+ let v_type = T.{ tsrc = "wrap: big_map: v" ; t = P_variable (Core.fresh_type_variable ()) } in
let aux_k (k , _v) =
let k' = type_expression_to_type_value k in
c_equation k_type k' "wrap: big_map: key" in
@@ -241,7 +241,7 @@ let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.t
[
(* TODO: this doesn't tag big_maps uniquely (i.e. if two
big_map have the same type, they can be swapped. *)
- c_equation (P_variable whole_expr) (p_constant C_big_map [k_type ; v_type]) "wrap: big_map: whole" ;
+ c_equation ({ tsrc = "wrap: big_map: whole" ; t = P_variable whole_expr}) (p_constant C_big_map [k_type ; v_type]) "wrap: big_map: whole" ;
] @ equations_k @ equations_v , whole_expr
let application : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -250,7 +250,7 @@ let application : T.type_expression -> T.type_expression -> (constraints * T.typ
let f' = type_expression_to_type_value f in
let arg' = type_expression_to_type_value arg in
[
- c_equation f' (p_constant C_arrow [arg' ; P_variable whole_expr]) "wrap: application: f" ;
+ c_equation f' (p_constant C_arrow [arg' ; { tsrc = "wrap: application: whole" ; t = P_variable whole_expr }]) "wrap: application: f" ;
] , whole_expr
let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -258,10 +258,10 @@ let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_va
let ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind in
let whole_expr = Core.fresh_type_variable () in
- let v = Core.fresh_type_variable () in
+ let v = T.{ tsrc = "wrap: look_up: ds" ; t = P_variable (Core.fresh_type_variable ()) } in
[
- c_equation ds' (p_constant C_map [ind' ; P_variable v]) "wrap: look_up: map" ;
- c_equation (P_variable whole_expr) (p_constant C_option [P_variable v]) "wrap: look_up: whole" ;
+ c_equation ds' (p_constant C_map [ind' ; v]) "wrap: look_up: map" ;
+ c_equation ({ tsrc = "wrap: look_up: whole" ; t = P_variable whole_expr }) (p_constant C_option [v]) "wrap: look_up: whole" ;
] , whole_expr
let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -271,7 +271,7 @@ let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_v
let whole_expr = Core.fresh_type_variable () in
[
c_equation a' (p_constant C_unit []) "wrap: sequence: first" ;
- c_equation b' (P_variable whole_expr) "wrap: sequence: second (whole)" ;
+ c_equation b' ({ tsrc = "wrap: sequence: whole" ; t = P_variable whole_expr}) "wrap: sequence: second (whole)" ;
] , whole_expr
let loop : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -280,9 +280,9 @@ let loop : T.type_expression -> T.type_expression -> (constraints * T.type_varia
let body' = type_expression_to_type_value body in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation expr' (P_variable Stage_common.Constant.t_bool) "wrap: loop: expr" ;
+ c_equation expr' ({ tsrc = "built-in type" ; t = P_variable Stage_common.Constant.t_bool }) "wrap: loop: expr" ;
c_equation body' (p_constant C_unit []) "wrap: loop: body" ;
- c_equation (P_variable whole_expr) (p_constant C_unit []) "wrap: loop: whole (unit)" ;
+ c_equation (p_constant C_unit []) ({ tsrc = "wrap: loop: whole" ; t = P_variable whole_expr}) "wrap: loop: whole (unit)" ;
] , whole_expr
let let_in : T.type_expression -> T.type_expression option -> T.type_expression -> (constraints * T.type_variable) =
@@ -294,7 +294,7 @@ let let_in : T.type_expression -> T.type_expression option -> T.type_expression
| Some annot -> [c_equation rhs' (type_expression_to_type_value annot) "wrap: let_in: rhs"] in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation result' (P_variable whole_expr) "wrap: let_in: result (whole)" ;
+ c_equation result' { tsrc = "wrap: let_in: whole" ; t = P_variable whole_expr } "wrap: let_in: result (whole)" ;
] @ rhs_tv_opt', whole_expr
let recursive : T.type_expression -> (constraints * T.type_variable) =
@@ -302,7 +302,7 @@ let recursive : T.type_expression -> (constraints * T.type_variable) =
let fun_type = type_expression_to_type_value fun_type in
let whole_expr = Core.fresh_type_variable () in
[
- c_equation fun_type (P_variable whole_expr) "wrap: recursive: fun_type (whole)" ;
+ c_equation fun_type ({ tsrc = "wrap: recursive: whole" ; t = P_variable whole_expr }) "wrap: recursive: fun_type (whole)" ;
], whole_expr
let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -312,7 +312,7 @@ let assign : T.type_expression -> T.type_expression -> (constraints * T.type_var
let whole_expr = Core.fresh_type_variable () in
[
c_equation v' e' "wrap: assign: var type must eq rhs type" ;
- c_equation (P_variable whole_expr) (p_constant C_unit []) "wrap: assign: unit (whole)" ;
+ c_equation { tsrc = "wrap: assign: whole" ; t = P_variable whole_expr } (p_constant C_unit []) "wrap: assign: unit (whole)" ;
] , whole_expr
let annotation : T.type_expression -> T.type_expression -> (constraints * T.type_variable) =
@@ -322,14 +322,14 @@ let annotation : T.type_expression -> T.type_expression -> (constraints * T.type
let whole_expr = Core.fresh_type_variable () in
[
c_equation e' annot' "wrap: annotation: expr type must eq annot" ;
- c_equation e' (P_variable whole_expr) "wrap: annotation: whole" ;
+ c_equation e' { tsrc = "wrap: annotation: whole" ; t = P_variable whole_expr } "wrap: annotation: whole" ;
] , whole_expr
let matching : T.type_expression list -> (constraints * T.type_variable) =
fun es ->
let whole_expr = Core.fresh_type_variable () in
let type_expressions = (List.map type_expression_to_type_value es) in
- let cs = List.map (fun e -> c_equation (P_variable whole_expr) e "wrap: matching: case (whole)") type_expressions
+ let cs = List.map (fun e -> c_equation { tsrc = "wrap: matching: case" ; t = P_variable whole_expr } e "wrap: matching: case (whole)") type_expressions
in cs, whole_expr
let fresh_binder () =
@@ -339,24 +339,26 @@ let lambda
: T.type_expression ->
T.type_expression option ->
T.type_expression option ->
+ T.type_expression ->
(constraints * T.type_variable) =
- fun fresh arg body ->
+ fun fresh arg output result ->
let whole_expr = Core.fresh_type_variable () in
- let unification_arg = Core.fresh_type_variable () in
- let unification_body = Core.fresh_type_variable () in
+ let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in
+ let unification_output = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in
+ let result' = type_expression_to_type_value result in
let arg' = match arg with
None -> []
- | Some arg -> [c_equation (P_variable unification_arg) (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in
- let body' = match body with
+ | Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in
+ let output' = match output with
None -> []
- | Some body -> [c_equation (P_variable unification_body) (type_expression_to_type_value body) "wrap: lambda: body annot"]
+ | Some output -> [c_equation unification_output (type_expression_to_type_value output) "wrap: lambda: output annot"]
in [
- c_equation (type_expression_to_type_value fresh) (P_variable unification_arg) "wrap: lambda: arg" ;
- c_equation (P_variable whole_expr)
- (p_constant C_arrow ([P_variable unification_arg ;
- P_variable unification_body]))
+ c_equation unification_output result' "wrap: lambda: result" ;
+ c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ;
+ c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr })
+ (p_constant C_arrow ([unification_arg ; unification_output]))
"wrap: lambda: arrow (whole)"
- ] @ arg' @ body' , whole_expr
+ ] @ arg' @ output' , whole_expr
(* This is pretty much a wrapper for an n-ary function. *)
let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
@@ -365,5 +367,5 @@ let constant : O.type_value -> T.type_expression list -> (constraints * T.type_v
let args' = List.map type_expression_to_type_value args in
let args_tuple = p_constant C_record args' in
[
- c_equation f (p_constant C_arrow ([args_tuple ; P_variable whole_expr])) "wrap: constant: as declared for built-in"
+ c_equation f (p_constant C_arrow ([args_tuple ; { tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr }])) "wrap: constant: as declared for built-in"
] , whole_expr
diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml
index 17af76c00..ca2a123a7 100644
--- a/src/passes/8-typer-old/typer.ml
+++ b/src/passes/8-typer-old/typer.ml
@@ -494,27 +494,25 @@ let rec type_program (p:I.program) : (O.program * O.typer_state) result =
let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in
let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in
- match d' with
- | None -> ok (e', acc)
- | Some d' -> ok (e', loc ed' d' :: acc)
+ ok (e', loc ed' d' :: acc)
in
let%bind (_, lst) =
trace (fun () -> program_error p ()) @@
bind_fold_list aux (DEnv.default, []) p in
ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ()))
-and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration option) result = function
- | Declaration_type (type_name , type_expression) ->
- let%bind tv = evaluate_type env type_expression in
- let env' = Environment.add_type (type_name) tv env in
- ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
+and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration) result = function
+ | Declaration_type (type_binder , type_expr) ->
+ let%bind tv = evaluate_type env type_expr in
+ let env' = Environment.add_type (type_binder) tv env in
+ ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } ))
| Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env in
- ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline ; post_env}))
+ ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline}))
)
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
@@ -674,6 +672,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ()))
+
and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae ->
let module L = Logger.Stateful() in
let return expr tv =
@@ -682,7 +681,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in
let location = ae.location in
- ok @@ make_e ~location expr tv e in
+ ok @@ make_e ~location expr tv in
let main_error =
let title () = "typing expression" in
let content () = "" in
@@ -736,7 +735,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in
let location = ae.location in
- ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv e
+ ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv
in
let%bind ae =
trace (simple_info "accessing") @@ aux e' path in
@@ -832,7 +831,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_expression in
- let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
+ let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in
let lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_expression lst' in
let%bind (opname', tv) =
@@ -853,7 +852,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' e' result in
let output_type = body.type_expression in
- let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in
+ let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in
let lst' = [lambda';v_initr] in
let tv_lst = List.map get_type_expression lst' in
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in
diff --git a/src/passes/8-typer-old/typer.mli b/src/passes/8-typer-old/typer.mli
index ff7009a8c..531a6b751 100644
--- a/src/passes/8-typer-old/typer.mli
+++ b/src/passes/8-typer-old/typer.mli
@@ -39,7 +39,7 @@ module Errors : sig
end
val type_program : I.program -> (O.program * O.typer_state) result
-val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration option) result
+val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration) result
(* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *)
val evaluate_type : environment -> I.type_expression -> O.type_expression result
val type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result
diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml
index f42d1ea37..a63a2893a 100644
--- a/src/passes/9-self_ast_typed/helpers.ml
+++ b/src/passes/9-self_ast_typed/helpers.ml
@@ -156,10 +156,11 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) ->
match x with
- | Declaration_constant {binder; expr ; inline ; post_env} -> (
+ | Declaration_constant {binder; expr ; inline} -> (
let%bind expr = map_expression m expr in
- ok (Declaration_constant {binder; expr ; inline ; post_env})
- )
+ ok (Declaration_constant {binder; expr ; inline})
+ )
+ | Declaration_type t -> ok (Declaration_type t)
in
bind_map_list (bind_map_location aux) p
@@ -246,11 +247,15 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin
and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with
- | Declaration_constant {binder ; expr ; inline ; post_env} -> (
+ | Declaration_constant {binder ; expr ; inline} -> (
let%bind (acc', expr) = fold_map_expression m acc expr in
- let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in
+ let wrap_content = Declaration_constant {binder ; expr ; inline} in
ok (acc', List.append acc_prg [{x with wrap_content}])
)
+ | Declaration_type t -> (
+ let wrap_content = Declaration_type t in
+ ok (acc, List.append acc_prg [{x with wrap_content}])
+ )
in
bind_fold_list aux (init,[]) p
@@ -298,30 +303,31 @@ type contract_type = {
}
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
- let main_decl = List.rev @@ List.filter
- (fun declt ->
- let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
- String.equal (Var.to_name binder) main_fname
- )
- program
+ let aux declt = match Location.unwrap declt with
+ | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
+ if String.equal (Var.to_name binder) main_fname
+ then Some p
+ else None
+ | Declaration_type _ -> None
in
- match main_decl with
- | (hd::_) -> (
- let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
- match expr.type_expression.type_content with
- | T_arrow {type1 ; type2} -> (
- match type1.type_content , type2.type_content with
- | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
- let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
- let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
- let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
- Ast_typed.assert_t_list_operation listop in
- let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
- Ast_typed.assert_type_expression_eq (storage,storage') in
- (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
- ok { parameter ; storage }
- | _ -> fail @@ Errors.bad_contract_io main_fname expr
- )
- | _ -> fail @@ Errors.bad_contract_io main_fname expr
+ let main_decl_opt = List.find_map aux @@ List.rev program in
+ let%bind main_decl =
+ trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@
+ main_decl_opt
+ in
+ let { binder=_ ; expr ; inline=_ } = main_decl in
+ match expr.type_expression.type_content with
+ | T_arrow {type1 ; type2} -> (
+ match type1.type_content , type2.type_content with
+ | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
+ let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
+ let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
+ let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
+ Ast_typed.assert_t_list_operation listop in
+ let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
+ Ast_typed.assert_type_expression_eq (storage,storage') in
+ (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
+ ok { parameter ; storage }
+ | _ -> fail @@ Errors.bad_contract_io main_fname expr
)
- | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")
+ | _ -> fail @@ Errors.bad_contract_io main_fname expr
diff --git a/src/passes/9-self_ast_typed/michelson_layout.ml b/src/passes/9-self_ast_typed/michelson_layout.ml
index 2211715b9..ce59c0898 100644
--- a/src/passes/9-self_ast_typed/michelson_layout.ml
+++ b/src/passes/9-self_ast_typed/michelson_layout.ml
@@ -13,25 +13,25 @@ let accessor (record:expression) (path:label) (t:type_expression) =
{ expression_content = E_record_accessor {record; path} ;
location = Location.generated ;
type_expression = t ;
- environment = record.environment }
+ }
let constructor (constructor:constructor') (element:expression) (t:type_expression) =
{ expression_content = E_constructor { constructor ; element } ;
location = Location.generated ;
type_expression = t ;
- environment = element.environment }
+ }
let match_var (t:type_expression) =
{ expression_content = E_variable (Var.of_name "x") ;
location = Location.generated ;
type_expression = t ;
- environment = Environment.add_ez_binder (Var.of_name "x") t Environment.empty}
+ }
let matching (e:expression) matchee cases =
{ expression_content = E_matching {matchee ; cases};
location = Location.generated ;
type_expression = e.type_expression ;
- environment = e.environment }
+ }
let rec descend_types s lmap i =
if i > 0 then
@@ -105,7 +105,7 @@ let rec to_right_comb_record
let exp = { expression_content = E_record_accessor {record = prev ; path = label } ;
location = Location.generated ;
type_expression = field_type ;
- environment = prev.environment } in
+ } in
let conv_map' = LMap.add (Label "0") exp conv_map in
LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map'
@@ -275,4 +275,4 @@ let peephole_expression : expression -> expression result = fun e ->
return match_expr.expression_content
| _ -> return e.expression_content
)
- | _ as e -> return e
\ No newline at end of file
+ | _ as e -> return e
diff --git a/src/passes/9-self_ast_typed/self_ast_typed.ml b/src/passes/9-self_ast_typed/self_ast_typed.ml
index 77b50ce9c..442564638 100644
--- a/src/passes/9-self_ast_typed/self_ast_typed.ml
+++ b/src/passes/9-self_ast_typed/self_ast_typed.ml
@@ -13,8 +13,7 @@ let contract_passes = [
let all_program program =
let all_p = List.map Helpers.map_program all_passes in
let%bind program' = bind_chain all_p program in
- let program'' = Recompute_environment.program Environment.default program' in
- ok program''
+ ok program'
let all_expression =
let all_p = List.map Helpers.map_expression all_passes in
diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml
index ce870c27c..dc63d5573 100644
--- a/src/passes/operators/operators.ml
+++ b/src/passes/operators/operators.ml
@@ -434,17 +434,17 @@ module Typer = struct
module Operators_types = struct
open Typesystem.Shorthands
- let tc_subarg a b c = tc [a;b;c] [ (*TODO…*) ]
- let tc_sizearg a = tc [a] [ [int] ]
- let tc_packable a = tc [a] [ [int] ; [string] ; [bool] (*TODO…*) ]
- let tc_timargs a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
- let tc_edivargs a b c = tc [a;b;c] [ (*TODO…*) ]
- let tc_divargs a b c = tc [a;b;c] [ (*TODO…*) ]
- let tc_modargs a b c = tc [a;b;c] [ (*TODO…*) ]
- let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ]
- let tc_comparable a = tc [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ]
- let tc_concatable a = tc [a] [ [string] ; [bytes] ]
- let tc_storable a = tc [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
+ let tc_subarg a b c = tc "arguments for (-)" [a;b;c] [ (*TODO…*) ]
+ let tc_sizearg a = tc "arguments for size" [a] [ [int] ]
+ let tc_packable a = tc "packable" [a] [ [int] ; [string] ; [bool] (*TODO…*) ]
+ let tc_timargs a b c = tc "arguments for ( * )" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
+ let tc_edivargs a b c = tc "arguments for ediv" [a;b;c] [ (*TODO…*) ]
+ let tc_divargs a b c = tc "arguments for div" [a;b;c] [ (*TODO…*) ]
+ let tc_modargs a b c = tc "arguments for mod" [a;b;c] [ (*TODO…*) ]
+ let tc_addargs a b c = tc "arguments for (+)" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ]
+ let tc_comparable a = tc "comparable" [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ]
+ let tc_concatable a = tc "concatenable" [a] [ [string] ; [bytes] ]
+ let tc_storable a = tc "storable" [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
let t_none = forall "a" @@ fun a -> option a
diff --git a/src/stages/1-ast_imperative/ast_imperative.ml b/src/stages/1-ast_imperative/ast_imperative.ml
index e9614490a..7fa34e677 100644
--- a/src/stages/1-ast_imperative/ast_imperative.ml
+++ b/src/stages/1-ast_imperative/ast_imperative.ml
@@ -3,6 +3,5 @@ include Types
(* include Misc *)
include Combinators
module Types = Types
-module Misc = Misc
module PP=PP
module Combinators = Combinators
diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml
deleted file mode 100644
index cf27a497d..000000000
--- a/src/stages/1-ast_imperative/misc.ml
+++ /dev/null
@@ -1,353 +0,0 @@
-open Trace
-open Types
-
-open Stage_common.Helpers
-module Errors = struct
- let different_literals_because_different_types name a b () =
- let title () = "literals have different types: " ^ name in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-
- let different_literals name a b () =
- let title () = name ^ " are different" in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-
- let error_uncomparable_literals name a b () =
- let title () = name ^ " are not comparable" in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-end
-open Errors
-
-let assert_literal_eq (a, b : literal * literal) : unit result =
- match (a, b) with
- | Literal_int a, Literal_int b when a = b -> ok ()
- | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b
- | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b
- | Literal_nat a, Literal_nat b when a = b -> ok ()
- | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b
- | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b
- | Literal_timestamp a, Literal_timestamp b when a = b -> ok ()
- | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b
- | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b
- | Literal_mutez a, Literal_mutez b when a = b -> ok ()
- | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b
- | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b
- | Literal_string a, Literal_string b when a = b -> ok ()
- | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b
- | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b
- | Literal_bytes a, Literal_bytes b when a = b -> ok ()
- | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b
- | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
- | Literal_void, Literal_void -> ok ()
- | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
- | Literal_unit, Literal_unit -> ok ()
- | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
- | Literal_address a, Literal_address b when a = b -> ok ()
- | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b
- | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b
- | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
- | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
- | Literal_signature a, Literal_signature b when a = b -> ok ()
- | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b
- | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b
- | Literal_key a, Literal_key b when a = b -> ok ()
- | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b
- | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b
- | Literal_key_hash a, Literal_key_hash b when a = b -> ok ()
- | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b
- | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b
- | Literal_chain_id a, Literal_chain_id b when a = b -> ok ()
- | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b
- | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
-
-let rec assert_value_eq (a, b: (expression * expression )) : unit result =
- Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b;
- let error_content () =
- Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b
- in
- trace (fun () -> error (thunk "not equal") error_content ()) @@
- match (a.expression_content , b.expression_content) with
- | E_literal a , E_literal b ->
- assert_literal_eq (a, b)
- | E_literal _ , _ ->
- simple_fail "comparing a literal with not a literal"
- | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (
- let%bind lst =
- generic_try (simple_error "constants with different number of elements")
- (fun () -> List.combine ca.arguments cb.arguments) in
- let%bind _all = bind_list @@ List.map assert_value_eq lst in
- ok ()
- )
- | E_constant _ , E_constant _ ->
- simple_fail "different constants"
- | E_constant _ , _ ->
- let error_content () =
- Format.asprintf "%a vs %a"
- PP.expression a
- PP.expression b
- in
- fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ())
-
- | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> (
- let%bind _eq = assert_value_eq (ca.element, cb.element) in
- ok ()
- )
- | E_constructor _, E_constructor _ ->
- simple_fail "different constructors"
- | E_constructor _, _ ->
- simple_fail "comparing constructor with other expression"
-
-
- | E_record sma, E_record smb -> (
- let aux _ a b =
- match a, b with
- | Some a, Some b -> Some (assert_value_eq (a, b))
- | _ -> Some (simple_fail "different record keys")
- in
- let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
- ok ()
- )
- | E_record _, _ ->
- simple_fail "comparing record with other expression"
-
- | E_record_update ura, E_record_update urb ->
- let _ =
- generic_try (simple_error "Updating different record") @@
- fun () -> assert_value_eq (ura.record, urb.record) in
- let aux (Label a,Label b) =
- assert (String.equal a b)
- in
- let () = aux (ura.path, urb.path) in
- let%bind () = assert_value_eq (ura.update,urb.update) in
- ok ()
- | E_record_update _, _ ->
- simple_fail "comparing record update with other expression"
-
- | E_tuple lsta, E_tuple lstb -> (
- let%bind lst =
- generic_try (simple_error "tuples with different number of elements")
- (fun () -> List.combine lsta lstb) in
- let%bind _all = bind_list @@ List.map assert_value_eq lst in
- ok ()
- )
- | E_tuple _, _ ->
- simple_fail "comparing tuple with other expression"
-
- | E_tuple_update uta, E_tuple_update utb ->
- let _ =
- generic_try (simple_error "Updating different tuple") @@
- fun () -> assert_value_eq (uta.tuple, utb.tuple) in
- let () = assert (uta.path == utb.path) in
- let%bind () = assert_value_eq (uta.update,utb.update) in
- ok ()
- | E_tuple_update _, _ ->
- simple_fail "comparing tuple update with other expression"
-
- | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
- let%bind lst = generic_try (simple_error "maps of different lengths")
- (fun () ->
- let lsta' = List.sort compare lsta in
- let lstb' = List.sort compare lstb in
- List.combine lsta' lstb') in
- let aux = fun ((ka, va), (kb, vb)) ->
- let%bind _ = assert_value_eq (ka, kb) in
- let%bind _ = assert_value_eq (va, vb) in
- ok () in
- let%bind _all = bind_map_list aux lst in
- ok ()
- )
- | (E_map _ | E_big_map _), _ ->
- simple_fail "comparing map with other expression"
-
- | E_list lsta, E_list lstb -> (
- let%bind lst =
- generic_try (simple_error "list of different lengths")
- (fun () -> List.combine lsta lstb) in
- let%bind _all = bind_map_list assert_value_eq lst in
- ok ()
- )
- | E_list _, _ ->
- simple_fail "comparing list with other expression"
-
- | E_set lsta, E_set lstb -> (
- let lsta' = List.sort (compare) lsta in
- let lstb' = List.sort (compare) lstb in
- let%bind lst =
- generic_try (simple_error "set of different lengths")
- (fun () -> List.combine lsta' lstb') in
- let%bind _all = bind_map_list assert_value_eq lst in
- ok ()
- )
- | E_set _, _ ->
- simple_fail "comparing set with other expression"
-
- | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
- | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
- | (E_variable _, _) | (E_lambda _, _)
- | (E_application _, _) | (E_let_in _, _)
- | (E_recursive _,_)
- | (E_record_accessor _, _) | (E_tuple_accessor _, _)
- | (E_look_up _, _)
- | (E_matching _, _) | (E_cond _, _)
- | (E_sequence _, _) | (E_skip, _)
- | (E_assign _, _)
- | (E_for _, _) | (E_for_each _, _)
- | (E_while _, _) -> simple_fail "comparing not a value"
-
-let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
-
-(* module Rename = struct
- * open Trace
- *
- * module Type = struct
- * (\* Type renaming, not needed. Yet. *\)
- * end
- *
- * module Value = struct
- * type renaming = string * (string * access_path) (\* src -> dst *\)
- * type renamings = renaming list
- * let filter (r:renamings) (s:string) : renamings =
- * List.filter (fun (x, _) -> not (x = s)) r
- * let filters (r:renamings) (ss:string list) : renamings =
- * List.filter (fun (x, _) -> not (List.mem x ss)) r
- *
- * let rec rename_instruction (r:renamings) (i:instruction) : instruction result =
- * match i with
- * | I_assignment ({name;annotated_expression = e} as a) -> (
- * match List.assoc_opt name r with
- * | None ->
- * let%bind annotated_expression = rename_annotated_expression (filter r name) e in
- * ok (I_assignment {a with annotated_expression})
- * | Some (name', lst) -> (
- * let%bind annotated_expression = rename_annotated_expression r e in
- * match lst with
- * | [] -> ok (I_assignment {name = name' ; annotated_expression})
- * | lst ->
- * let (hds, tl) =
- * let open List in
- * let r = rev lst in
- * rev @@ tl r, hd r
- * in
- * let%bind tl' = match tl with
- * | Access_record n -> ok n
- * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in
- * ok (I_record_patch (name', hds, [tl', annotated_expression]))
- * )
- * )
- * | I_skip -> ok I_skip
- * | I_fail e ->
- * let%bind e' = rename_annotated_expression r e in
- * ok (I_fail e')
- * | I_loop (cond, body) ->
- * let%bind cond' = rename_annotated_expression r cond in
- * let%bind body' = rename_block r body in
- * ok (I_loop (cond', body'))
- * | I_matching (ae, m) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * let%bind m' = rename_matching rename_block r m in
- * ok (I_matching (ae', m'))
- * | I_record_patch (v, path, lst) ->
- * let aux (x, y) =
- * let%bind y' = rename_annotated_expression (filter r v) y in
- * ok (x, y') in
- * let%bind lst' = bind_map_list aux lst in
- * match List.assoc_opt v r with
- * | None -> (
- * ok (I_record_patch (v, path, lst'))
- * )
- * | Some (v', path') -> (
- * ok (I_record_patch (v', path' @ path, lst'))
- * )
- * and rename_block (r:renamings) (bl:block) : block result =
- * bind_map_list (rename_instruction r) bl
- *
- * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result =
- * fun f r m ->
- * match m with
- * | Match_bool { match_true = mt ; match_false = mf } ->
- * let%bind match_true = f r mt in
- * let%bind match_false = f r mf in
- * ok (Match_bool {match_true ; match_false})
- * | Match_option { match_none = mn ; match_some = (some, ms) } ->
- * let%bind match_none = f r mn in
- * let%bind ms' = f (filter r some) ms in
- * ok (Match_option {match_none ; match_some = (some, ms')})
- * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } ->
- * let%bind match_nil = f r mn in
- * let%bind mc' = f (filters r [hd;tl]) mc in
- * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')})
- * | Match_tuple (lst, body) ->
- * let%bind body' = f (filters r lst) body in
- * ok (Match_tuple (lst, body'))
- *
- * and rename_matching_instruction = fun x -> rename_matching rename_block x
- *
- * and rename_matching_expr = fun x -> rename_matching rename_expression x
- *
- * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result =
- * let%bind expression = rename_expression r ae.expression in
- * ok {ae with expression}
- *
- * and rename_expression : renamings -> expression -> expression result = fun r e ->
- * match e with
- * | E_literal _ as l -> ok l
- * | E_constant (name, lst) ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_constant (name, lst'))
- * | E_constructor (name, ae) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * ok (E_constructor (name, ae'))
- * | E_variable v -> (
- * match List.assoc_opt v r with
- * | None -> ok (E_variable v)
- * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path))
- * )
- * | E_lambda ({binder;body;result} as l) ->
- * let r' = filter r binder in
- * let%bind body = rename_block r' body in
- * let%bind result = rename_annotated_expression r' result in
- * ok (E_lambda {l with body ; result})
- * | E_application (f, arg) ->
- * let%bind f' = rename_annotated_expression r f in
- * let%bind arg' = rename_annotated_expression r arg in
- * ok (E_application (f', arg'))
- * | E_tuple lst ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_tuple lst')
- * | E_accessor (ae, p) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * ok (E_accessor (ae', p))
- * | E_record sm ->
- * let%bind sm' = bind_smap
- * @@ SMap.map (rename_annotated_expression r) sm in
- * ok (E_record sm')
- * | E_map m ->
- * let%bind m' = bind_map_list
- * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in
- * ok (E_map m')
- * | E_list lst ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_list lst')
- * | E_look_up m ->
- * let%bind m' = bind_map_pair (rename_annotated_expression r) m in
- * ok (E_look_up m')
- * | E_matching (ae, m) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * let%bind m' = rename_matching rename_annotated_expression r m in
- * ok (E_matching (ae', m'))
- * end
- * end *)
diff --git a/src/stages/1-ast_imperative/misc.mli b/src/stages/1-ast_imperative/misc.mli
deleted file mode 100644
index 0784d109c..000000000
--- a/src/stages/1-ast_imperative/misc.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-open Trace
-open Types
-
-
-(*
-
-module Errors : sig
- val different_literals_because_different_types : name -> literal -> literal -> unit -> error
-
- val different_literals : name -> literal -> literal -> unit -> error
-
- val error_uncomparable_literals : name -> literal -> literal -> unit -> error
-end
-
-val assert_literal_eq : ( literal * literal ) -> unit result
-*)
-
-val assert_value_eq : ( expression * expression ) -> unit result
-
-val is_value_eq : ( expression * expression ) -> bool
diff --git a/src/stages/2-ast_sugar/ast_sugar.ml b/src/stages/2-ast_sugar/ast_sugar.ml
index e9614490a..7fa34e677 100644
--- a/src/stages/2-ast_sugar/ast_sugar.ml
+++ b/src/stages/2-ast_sugar/ast_sugar.ml
@@ -3,6 +3,5 @@ include Types
(* include Misc *)
include Combinators
module Types = Types
-module Misc = Misc
module PP=PP
module Combinators = Combinators
diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml
deleted file mode 100644
index f65e95796..000000000
--- a/src/stages/2-ast_sugar/misc.ml
+++ /dev/null
@@ -1,350 +0,0 @@
-open Trace
-open Types
-
-open Stage_common.Helpers
-module Errors = struct
- let different_literals_because_different_types name a b () =
- let title () = "literals have different types: " ^ name in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-
- let different_literals name a b () =
- let title () = name ^ " are different" in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-
- let error_uncomparable_literals name a b () =
- let title () = name ^ " are not comparable" in
- let message () = "" in
- let data = [
- ("a" , fun () -> Format.asprintf "%a" PP.literal a) ;
- ("b" , fun () -> Format.asprintf "%a" PP.literal b )
- ] in
- error ~data title message ()
-end
-open Errors
-
-let assert_literal_eq (a, b : literal * literal) : unit result =
- match (a, b) with
- | Literal_int a, Literal_int b when a = b -> ok ()
- | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b
- | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b
- | Literal_nat a, Literal_nat b when a = b -> ok ()
- | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b
- | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b
- | Literal_timestamp a, Literal_timestamp b when a = b -> ok ()
- | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b
- | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b
- | Literal_mutez a, Literal_mutez b when a = b -> ok ()
- | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b
- | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b
- | Literal_string a, Literal_string b when a = b -> ok ()
- | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b
- | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b
- | Literal_bytes a, Literal_bytes b when a = b -> ok ()
- | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b
- | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b
- | Literal_void, Literal_void -> ok ()
- | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b
- | Literal_unit, Literal_unit -> ok ()
- | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b
- | Literal_address a, Literal_address b when a = b -> ok ()
- | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b
- | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b
- | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b
- | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b
- | Literal_signature a, Literal_signature b when a = b -> ok ()
- | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b
- | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b
- | Literal_key a, Literal_key b when a = b -> ok ()
- | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b
- | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b
- | Literal_key_hash a, Literal_key_hash b when a = b -> ok ()
- | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b
- | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b
- | Literal_chain_id a, Literal_chain_id b when a = b -> ok ()
- | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b
- | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b
-
-let rec assert_value_eq (a, b: (expression * expression )) : unit result =
- Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b;
- let error_content () =
- Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b
- in
- trace (fun () -> error (thunk "not equal") error_content ()) @@
- match (a.expression_content , b.expression_content) with
- | E_literal a , E_literal b ->
- assert_literal_eq (a, b)
- | E_literal _ , _ ->
- simple_fail "comparing a literal with not a literal"
- | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> (
- let%bind lst =
- generic_try (simple_error "constants with different number of elements")
- (fun () -> List.combine ca.arguments cb.arguments) in
- let%bind _all = bind_list @@ List.map assert_value_eq lst in
- ok ()
- )
- | E_constant _ , E_constant _ ->
- simple_fail "different constants"
- | E_constant _ , _ ->
- let error_content () =
- Format.asprintf "%a vs %a"
- PP.expression a
- PP.expression b
- in
- fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ())
-
- | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> (
- let%bind _eq = assert_value_eq (ca.element, cb.element) in
- ok ()
- )
- | E_constructor _, E_constructor _ ->
- simple_fail "different constructors"
- | E_constructor _, _ ->
- simple_fail "comparing constructor with other expression"
-
-
- | E_record sma, E_record smb -> (
- let aux _ a b =
- match a, b with
- | Some a, Some b -> Some (assert_value_eq (a, b))
- | _ -> Some (simple_fail "different record keys")
- in
- let%bind _all = bind_lmap @@ LMap.merge aux sma smb in
- ok ()
- )
- | E_record _, _ ->
- simple_fail "comparing record with other expression"
-
- | E_record_update ura, E_record_update urb ->
- let _ =
- generic_try (simple_error "Updating different record") @@
- fun () -> assert_value_eq (ura.record, urb.record) in
- let aux (Label a,Label b) =
- assert (String.equal a b)
- in
- let () = aux (ura.path, urb.path) in
- let%bind () = assert_value_eq (ura.update,urb.update) in
- ok ()
- | E_record_update _, _ ->
- simple_fail "comparing record update with other expression"
-
- | E_tuple lsta, E_tuple lstb -> (
- let%bind lst =
- generic_try (simple_error "tuples with different number of elements")
- (fun () -> List.combine lsta lstb) in
- let%bind _all = bind_list @@ List.map assert_value_eq lst in
- ok ()
- )
- | E_tuple _, _ ->
- simple_fail "comparing tuple with other expression"
-
- | E_tuple_update uta, E_tuple_update utb ->
- let _ =
- generic_try (simple_error "Updating different tuple") @@
- fun () -> assert_value_eq (uta.tuple, utb.tuple) in
- let () = assert (uta.path == utb.path) in
- let%bind () = assert_value_eq (uta.update,utb.update) in
- ok ()
- | E_tuple_update _, _ ->
- simple_fail "comparing tuple update with other expression"
-
- | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
- let%bind lst = generic_try (simple_error "maps of different lengths")
- (fun () ->
- let lsta' = List.sort compare lsta in
- let lstb' = List.sort compare lstb in
- List.combine lsta' lstb') in
- let aux = fun ((ka, va), (kb, vb)) ->
- let%bind _ = assert_value_eq (ka, kb) in
- let%bind _ = assert_value_eq (va, vb) in
- ok () in
- let%bind _all = bind_map_list aux lst in
- ok ()
- )
- | (E_map _ | E_big_map _), _ ->
- simple_fail "comparing map with other expression"
-
- | E_list lsta, E_list lstb -> (
- let%bind lst =
- generic_try (simple_error "list of different lengths")
- (fun () -> List.combine lsta lstb) in
- let%bind _all = bind_map_list assert_value_eq lst in
- ok ()
- )
- | E_list _, _ ->
- simple_fail "comparing list with other expression"
-
- | E_set lsta, E_set lstb -> (
- let lsta' = List.sort (compare) lsta in
- let lstb' = List.sort (compare) lstb in
- let%bind lst =
- generic_try (simple_error "set of different lengths")
- (fun () -> List.combine lsta' lstb') in
- let%bind _all = bind_map_list assert_value_eq lst in
- ok ()
- )
- | E_set _, _ ->
- simple_fail "comparing set with other expression"
-
- | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
- | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
- | (E_variable _, _) | (E_lambda _, _)
- | (E_application _, _) | (E_let_in _, _)
- | (E_recursive _,_)
- | (E_record_accessor _, _) | (E_tuple_accessor _, _)
- | (E_look_up _, _)
- | (E_matching _, _) | (E_cond _, _)
- | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
-
-let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)
-
-(* module Rename = struct
- * open Trace
- *
- * module Type = struct
- * (\* Type renaming, not needed. Yet. *\)
- * end
- *
- * module Value = struct
- * type renaming = string * (string * access_path) (\* src -> dst *\)
- * type renamings = renaming list
- * let filter (r:renamings) (s:string) : renamings =
- * List.filter (fun (x, _) -> not (x = s)) r
- * let filters (r:renamings) (ss:string list) : renamings =
- * List.filter (fun (x, _) -> not (List.mem x ss)) r
- *
- * let rec rename_instruction (r:renamings) (i:instruction) : instruction result =
- * match i with
- * | I_assignment ({name;annotated_expression = e} as a) -> (
- * match List.assoc_opt name r with
- * | None ->
- * let%bind annotated_expression = rename_annotated_expression (filter r name) e in
- * ok (I_assignment {a with annotated_expression})
- * | Some (name', lst) -> (
- * let%bind annotated_expression = rename_annotated_expression r e in
- * match lst with
- * | [] -> ok (I_assignment {name = name' ; annotated_expression})
- * | lst ->
- * let (hds, tl) =
- * let open List in
- * let r = rev lst in
- * rev @@ tl r, hd r
- * in
- * let%bind tl' = match tl with
- * | Access_record n -> ok n
- * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in
- * ok (I_record_patch (name', hds, [tl', annotated_expression]))
- * )
- * )
- * | I_skip -> ok I_skip
- * | I_fail e ->
- * let%bind e' = rename_annotated_expression r e in
- * ok (I_fail e')
- * | I_loop (cond, body) ->
- * let%bind cond' = rename_annotated_expression r cond in
- * let%bind body' = rename_block r body in
- * ok (I_loop (cond', body'))
- * | I_matching (ae, m) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * let%bind m' = rename_matching rename_block r m in
- * ok (I_matching (ae', m'))
- * | I_record_patch (v, path, lst) ->
- * let aux (x, y) =
- * let%bind y' = rename_annotated_expression (filter r v) y in
- * ok (x, y') in
- * let%bind lst' = bind_map_list aux lst in
- * match List.assoc_opt v r with
- * | None -> (
- * ok (I_record_patch (v, path, lst'))
- * )
- * | Some (v', path') -> (
- * ok (I_record_patch (v', path' @ path, lst'))
- * )
- * and rename_block (r:renamings) (bl:block) : block result =
- * bind_map_list (rename_instruction r) bl
- *
- * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result =
- * fun f r m ->
- * match m with
- * | Match_bool { match_true = mt ; match_false = mf } ->
- * let%bind match_true = f r mt in
- * let%bind match_false = f r mf in
- * ok (Match_bool {match_true ; match_false})
- * | Match_option { match_none = mn ; match_some = (some, ms) } ->
- * let%bind match_none = f r mn in
- * let%bind ms' = f (filter r some) ms in
- * ok (Match_option {match_none ; match_some = (some, ms')})
- * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } ->
- * let%bind match_nil = f r mn in
- * let%bind mc' = f (filters r [hd;tl]) mc in
- * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')})
- * | Match_tuple (lst, body) ->
- * let%bind body' = f (filters r lst) body in
- * ok (Match_tuple (lst, body'))
- *
- * and rename_matching_instruction = fun x -> rename_matching rename_block x
- *
- * and rename_matching_expr = fun x -> rename_matching rename_expression x
- *
- * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result =
- * let%bind expression = rename_expression r ae.expression in
- * ok {ae with expression}
- *
- * and rename_expression : renamings -> expression -> expression result = fun r e ->
- * match e with
- * | E_literal _ as l -> ok l
- * | E_constant (name, lst) ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_constant (name, lst'))
- * | E_constructor (name, ae) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * ok (E_constructor (name, ae'))
- * | E_variable v -> (
- * match List.assoc_opt v r with
- * | None -> ok (E_variable v)
- * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path))
- * )
- * | E_lambda ({binder;body;result} as l) ->
- * let r' = filter r binder in
- * let%bind body = rename_block r' body in
- * let%bind result = rename_annotated_expression r' result in
- * ok (E_lambda {l with body ; result})
- * | E_application (f, arg) ->
- * let%bind f' = rename_annotated_expression r f in
- * let%bind arg' = rename_annotated_expression r arg in
- * ok (E_application (f', arg'))
- * | E_tuple lst ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_tuple lst')
- * | E_accessor (ae, p) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * ok (E_accessor (ae', p))
- * | E_record sm ->
- * let%bind sm' = bind_smap
- * @@ SMap.map (rename_annotated_expression r) sm in
- * ok (E_record sm')
- * | E_map m ->
- * let%bind m' = bind_map_list
- * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in
- * ok (E_map m')
- * | E_list lst ->
- * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in
- * ok (E_list lst')
- * | E_look_up m ->
- * let%bind m' = bind_map_pair (rename_annotated_expression r) m in
- * ok (E_look_up m')
- * | E_matching (ae, m) ->
- * let%bind ae' = rename_annotated_expression r ae in
- * let%bind m' = rename_matching rename_annotated_expression r m in
- * ok (E_matching (ae', m'))
- * end
- * end *)
diff --git a/src/stages/2-ast_sugar/misc.mli b/src/stages/2-ast_sugar/misc.mli
deleted file mode 100644
index 0784d109c..000000000
--- a/src/stages/2-ast_sugar/misc.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-open Trace
-open Types
-
-
-(*
-
-module Errors : sig
- val different_literals_because_different_types : name -> literal -> literal -> unit -> error
-
- val different_literals : name -> literal -> literal -> unit -> error
-
- val error_uncomparable_literals : name -> literal -> literal -> unit -> error
-end
-
-val assert_literal_eq : ( literal * literal ) -> unit result
-*)
-
-val assert_value_eq : ( expression * expression ) -> unit result
-
-val is_value_eq : ( expression * expression ) -> bool
diff --git a/src/stages/4-ast_typed/.gitignore b/src/stages/4-ast_typed/.gitignore
index 39f5407d5..189a4ee60 100644
--- a/src/stages/4-ast_typed/.gitignore
+++ b/src/stages/4-ast_typed/.gitignore
@@ -1,2 +1,3 @@
/generated_fold.ml
-
+/generated_map.ml
+/generated_o.ml
diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml
index 5691cac65..08e2f778c 100644
--- a/src/stages/4-ast_typed/PP.ml
+++ b/src/stages/4-ast_typed/PP.ml
@@ -326,8 +326,10 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit =
let declaration ppf (d : declaration) =
match d with
- | Declaration_constant {binder; expr; inline; post_env=_} ->
+ | Declaration_constant {binder; expr; inline} ->
fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline
+ | Declaration_type {type_binder; type_expr} ->
+ fprintf ppf "type %a = %a" type_variable type_binder type_expression type_expr
let program ppf (p : program) =
fprintf ppf "@[%a@]"
diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml
index c36fcebcb..1e503ace6 100644
--- a/src/stages/4-ast_typed/PP_generic.ml
+++ b/src/stages/4-ast_typed/PP_generic.ml
@@ -1,116 +1,119 @@
+open Types
open Fold
open Format
open PP_helpers
-let needs_parens = {
- generic = (fun state info ->
- match info.node_instance.instance_kind with
- | RecordInstance _ -> false
- | VariantInstance _ -> true
- | PolyInstance { poly =_; arguments=_; poly_continue } ->
- (poly_continue state)
- );
- type_variable = (fun _ _ _ -> true) ;
- bool = (fun _ _ _ -> false) ;
- int = (fun _ _ _ -> false) ;
- z = (fun _ _ _ -> false) ;
- string = (fun _ _ _ -> false) ;
- ligo_string = (fun _ _ _ -> false) ;
- bytes = (fun _ _ _ -> false) ;
- unit = (fun _ _ _ -> false) ;
- packed_internal_operation = (fun _ _ _ -> false) ;
- expression_variable = (fun _ _ _ -> false) ;
- constructor' = (fun _ _ _ -> false) ;
- location = (fun _ _ _ -> false) ;
- label = (fun _ _ _ -> false) ;
- ast_core_type_expression = (fun _ _ _ -> true) ;
- constructor_map = (fun _ _ _ _ -> false) ;
- label_map = (fun _ _ _ _ -> false) ;
- list = (fun _ _ _ _ -> false) ;
- location_wrap = (fun _ _ _ _ -> false) ;
- option = (fun _visitor _continue _state o ->
- match o with None -> false | Some _ -> true) ;
- poly_unionfind = (fun _ _ _ _ -> false) ;
- poly_set = (fun _ _ _ _ -> false) ;
- typeVariableMap = (fun _ _ _ _ -> false) ;
- }
+module M = struct
+ type no_state = NoState
+ let needs_parens = {
+ generic = (fun NoState info ->
+ match info.node_instance.instance_kind with
+ | RecordInstance _ -> false
+ | VariantInstance _ -> true
+ | PolyInstance { poly =_; arguments=_; poly_continue } ->
+ (poly_continue NoState)
+ );
+ generic_empty_ctor = (fun _ -> false) ;
+ type_variable = (fun _ _ _ -> true) ;
+ bool = (fun _ _ _ -> false) ;
+ int = (fun _ _ _ -> false) ;
+ z = (fun _ _ _ -> false) ;
+ string = (fun _ _ _ -> false) ;
+ ligo_string = (fun _ _ _ -> false) ;
+ bytes = (fun _ _ _ -> false) ;
+ unit = (fun _ _ _ -> false) ;
+ packed_internal_operation = (fun _ _ _ -> false) ;
+ expression_variable = (fun _ _ _ -> false) ;
+ constructor' = (fun _ _ _ -> false) ;
+ location = (fun _ _ _ -> false) ;
+ label = (fun _ _ _ -> false) ;
+ ast_core_type_expression = (fun _ _ _ -> true) ;
+ constructor_map = (fun _ _ _ _ -> false) ;
+ label_map = (fun _ _ _ _ -> false) ;
+ list = (fun _ _ _ _ -> false) ;
+ location_wrap = (fun _ _ _ _ -> false) ;
+ option = (fun _visitor _continue _state o ->
+ match o with None -> false | Some _ -> true) ;
+ poly_unionfind = (fun _ _ _ _ -> false) ;
+ poly_set = (fun _ _ _ _ -> false) ;
+ typeVariableMap = (fun _ _ _ _ -> false) ;
+ }
-let op ppf = {
- generic = (fun () info ->
- match info.node_instance.instance_kind with
- | RecordInstance { fields } ->
- let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) =
- fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in
- fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
- | VariantInstance { constructor ; _ } ->
- if constructor.cf_new_fold needs_parens false
- then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) ()
- else let spc = if String.equal constructor.cf.type_ "" then "" else " " in
- fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) ()
- | PolyInstance { poly=_; arguments=_; poly_continue } ->
- (poly_continue ())
- );
- int = (fun _visitor () i -> fprintf ppf "%i" i );
- type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
- bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ;
- z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ;
- string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ;
- ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ;
- bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ;
- unit = (fun _visitor () () -> fprintf ppf "()") ;
- packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ;
- expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ;
- constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ;
- location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ;
- label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ;
- ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
- constructor_map = (fun _visitor continue () cmap ->
- let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
- let aux ppf (Constructor k, v) =
- fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
- fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
- label_map = (fun _visitor continue () lmap ->
- let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
- let aux ppf (Label k, v) =
- fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in
- fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
- list = (fun _visitor continue () lst ->
- let aux ppf elt =
- fprintf ppf "%a" (fun _ppf -> continue ()) elt in
- fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
- location_wrap = (fun _visitor continue () lwrap ->
- let ({ wrap_content; location } : _ Location.wrap) = lwrap in
- fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location);
- (* list_ne = (fun _visitor continue () (first, lst) ->
- let aux ppf elt =
- fprintf ppf "%a" (fun _ppf -> continue ()) elt in
- fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *)
- option = (fun _visitor continue () o ->
- match o with
- | None -> fprintf ppf "None"
- | Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ;
- poly_unionfind = (fun _visitor continue () p ->
- let lst = (UnionFind.Poly2.partitions p) in
- let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]"
- (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p)
- (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in
- let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
- fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst);
- poly_set = (fun _visitor continue () set ->
- let lst = (RedBlackTrees.PolySet.elements set) in
- fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst);
- typeVariableMap = (fun _visitor continue () tvmap ->
- let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
- let aux ppf (k, v) =
- fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in
- fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
- }
+ let op ppf : (no_state, unit) fold_config = {
+ generic = (fun NoState info ->
+ match info.node_instance.instance_kind with
+ | RecordInstance { fields } ->
+ let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
+ fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in
+ fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
+ | VariantInstance { constructor ; _ } ->
+ if constructor.cf_new_fold needs_parens NoState
+ then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState
+ else let spc = if String.equal constructor.cf.type_ "" then "" else " " in
+ fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
+ | PolyInstance { poly=_; arguments=_; poly_continue } ->
+ (poly_continue NoState)
+ );
+ generic_empty_ctor = (fun NoState -> ()) ;
+ int = (fun _visitor NoState i -> fprintf ppf "%i" i );
+ type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ;
+ bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ;
+ z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ;
+ string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ;
+ ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ;
+ bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
+ unit = (fun _visitor NoState () -> fprintf ppf "()") ;
+ packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
+ expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ;
+ constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
+ location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
+ label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;
+ ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
+ constructor_map = (fun _visitor continue NoState cmap ->
+ let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
+ let aux ppf (Constructor k, v) =
+ fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
+ fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
+ label_map = (fun _visitor continue NoState lmap ->
+ let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
+ let aux ppf (Label k, v) =
+ fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
+ fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
+ list = (fun _visitor continue NoState lst ->
+ let aux ppf elt =
+ fprintf ppf "%a" (fun _ppf -> continue NoState) elt in
+ fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
+ location_wrap = (fun _visitor continue NoState lwrap ->
+ let ({ wrap_content; location } : _ Location.wrap) = lwrap in
+ fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
+ option = (fun _visitor continue NoState o ->
+ match o with
+ | None -> fprintf ppf "None"
+ | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
+ poly_unionfind = (fun _visitor continue NoState p ->
+ let lst = (UnionFind.Poly2.partitions p) in
+ let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]"
+ (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
+ (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in
+ let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in
+ fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst);
+ poly_set = (fun _visitor continue NoState set ->
+ let lst = (RedBlackTrees.PolySet.elements set) in
+ fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
+ typeVariableMap = (fun _visitor continue NoState tvmap ->
+ let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
+ let aux ppf (k, v) =
+ fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in
+ fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
+ }
-let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
- fold (op ppf) () v
+ let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
+ fold (op ppf) NoState v
+end
include Fold.Folds(struct
- type state = unit ;;
+ type in_state = M.no_state ;;
+ type out_state = unit ;;
type 'a t = formatter -> 'a -> unit ;;
- let f = print ;;
+ let f = M.print ;;
end)
diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml
new file mode 100644
index 000000000..99b532754
--- /dev/null
+++ b/src/stages/4-ast_typed/ast.ml
@@ -0,0 +1,625 @@
+[@@@warning "-30"]
+
+open Types_utils
+
+(* pseudo-typeclasses: interfaces that must be provided for arguments
+ of the givent polymmorphic types. For now, only one typeclass can
+ be specified for a given polymorphic type. The implementation is
+ provided by the Comparable module *)
+(*@ typeclass poly_unionfind comparable *)
+(*@ typeclass poly_set comparable *)
+
+type type_constant =
+ | TC_unit
+ | TC_string
+ | TC_bytes
+ | TC_nat
+ | TC_int
+ | TC_mutez
+ | TC_operation
+ | TC_address
+ | TC_key
+ | TC_key_hash
+ | TC_chain_id
+ | TC_signature
+ | TC_timestamp
+ | TC_void
+
+type te_cmap = ctor_content constructor_map
+and te_lmap = field_content label_map
+and type_meta = ast_core_type_expression option
+
+and type_content =
+ | T_sum of te_cmap
+ | T_record of te_lmap
+ | T_arrow of arrow
+ | T_variable of type_variable
+ | T_constant of type_constant
+ | T_operator of type_operator
+
+and arrow = {
+ type1: type_expression;
+ type2: type_expression;
+ }
+
+and annot_option = string option
+
+and ctor_content = {
+ ctor_type : type_expression;
+ michelson_annotation : annot_option;
+ ctor_decl_pos : int;
+}
+
+and field_content = {
+ field_type : type_expression;
+ michelson_annotation : annot_option;
+ field_decl_pos : int;
+}
+
+and type_map_args = {
+ k : type_expression;
+ v : type_expression;
+ }
+
+and michelson_or_args = {
+ l : type_expression;
+ r : type_expression;
+ }
+
+and type_operator =
+ | TC_contract of type_expression
+ | TC_option of type_expression
+ | TC_list of type_expression
+ | TC_set of type_expression
+ | TC_map of type_map_args
+ | TC_big_map of type_map_args
+ | TC_map_or_big_map of type_map_args
+
+and type_expression = {
+ type_content: type_content;
+ type_meta: type_meta;
+ location: location;
+ }
+
+type literal =
+ | Literal_unit
+ | Literal_int of z
+ | Literal_nat of z
+ | Literal_timestamp of z
+ | Literal_mutez of z
+ | Literal_string of ligo_string
+ | Literal_bytes of bytes
+ | Literal_address of string
+ | Literal_signature of string
+ | Literal_key of string
+ | Literal_key_hash of string
+ | Literal_chain_id of string
+ | Literal_void
+ | Literal_operation of packed_internal_operation
+
+
+and matching_content_cons = {
+ hd : expression_variable;
+ tl : expression_variable;
+ body : expression;
+ tv : type_expression;
+ }
+
+and matching_content_list = {
+ match_nil : expression ;
+ match_cons : matching_content_cons;
+ }
+
+and matching_content_some = {
+ opt : expression_variable ;
+ body : expression ;
+ tv : type_expression ;
+ }
+
+and matching_content_option = {
+ match_none : expression ;
+ match_some : matching_content_some ;
+ }
+
+and expression_variable_list = expression_variable list
+and type_expression_list = type_expression list
+
+and matching_content_tuple = {
+ vars : expression_variable_list ;
+ body : expression ;
+ tvs : type_expression_list ;
+ }
+
+and matching_content_case = {
+ constructor : constructor' ;
+ pattern : expression_variable ;
+ body : expression ;
+ }
+
+and matching_content_case_list = matching_content_case list
+
+and matching_content_variant = {
+ cases: matching_content_case_list;
+ tv: type_expression;
+ }
+
+and matching_expr =
+ | Match_list of matching_content_list
+ | Match_option of matching_content_option
+ | Match_tuple of matching_content_tuple
+ | Match_variant of matching_content_variant
+
+and constant' =
+ | C_INT
+ | C_UNIT
+ | C_NIL
+ | C_NOW
+ | C_IS_NAT
+ | C_SOME
+ | C_NONE
+ | C_ASSERTION
+ | C_ASSERT_INFERRED
+ | C_FAILWITH
+ | C_UPDATE
+ (* Loops *)
+ | C_ITER
+ | C_FOLD_WHILE
+ | C_FOLD_CONTINUE
+ | C_FOLD_STOP
+ | C_LOOP_LEFT
+ | C_LOOP_CONTINUE
+ | C_LOOP_STOP
+ | C_FOLD
+ (* MATH *)
+ | C_NEG
+ | C_ABS
+ | C_ADD
+ | C_SUB
+ | C_MUL
+ | C_EDIV
+ | C_DIV
+ | C_MOD
+ (* LOGIC *)
+ | C_NOT
+ | C_AND
+ | C_OR
+ | C_XOR
+ | C_LSL
+ | C_LSR
+ (* COMPARATOR *)
+ | C_EQ
+ | C_NEQ
+ | C_LT
+ | C_GT
+ | C_LE
+ | C_GE
+ (* Bytes/ String *)
+ | C_SIZE
+ | C_CONCAT
+ | C_SLICE
+ | C_BYTES_PACK
+ | C_BYTES_UNPACK
+ | C_CONS
+ (* Pair *)
+ | C_PAIR
+ | C_CAR
+ | C_CDR
+ | C_LEFT
+ | C_RIGHT
+ (* Set *)
+ | C_SET_EMPTY
+ | C_SET_LITERAL
+ | C_SET_ADD
+ | C_SET_REMOVE
+ | C_SET_ITER
+ | C_SET_FOLD
+ | C_SET_MEM
+ (* List *)
+ | C_LIST_EMPTY
+ | C_LIST_LITERAL
+ | C_LIST_ITER
+ | C_LIST_MAP
+ | C_LIST_FOLD
+ (* Maps *)
+ | C_MAP
+ | C_MAP_EMPTY
+ | C_MAP_LITERAL
+ | C_MAP_GET
+ | C_MAP_GET_FORCE
+ | C_MAP_ADD
+ | C_MAP_REMOVE
+ | C_MAP_UPDATE
+ | C_MAP_ITER
+ | C_MAP_MAP
+ | C_MAP_FOLD
+ | C_MAP_MEM
+ | C_MAP_FIND
+ | C_MAP_FIND_OPT
+ (* Big Maps *)
+ | C_BIG_MAP
+ | C_BIG_MAP_EMPTY
+ | C_BIG_MAP_LITERAL
+ (* Crypto *)
+ | C_SHA256
+ | C_SHA512
+ | C_BLAKE2b
+ | C_HASH
+ | C_HASH_KEY
+ | C_CHECK_SIGNATURE
+ | C_CHAIN_ID
+ (* Blockchain *)
+ | C_CALL
+ | C_CONTRACT
+ | C_CONTRACT_OPT
+ | C_CONTRACT_ENTRYPOINT
+ | C_CONTRACT_ENTRYPOINT_OPT
+ | C_AMOUNT
+ | C_BALANCE
+ | C_SOURCE
+ | C_SENDER
+ | C_ADDRESS
+ | C_SELF
+ | C_SELF_ADDRESS
+ | C_IMPLICIT_ACCOUNT
+ | C_SET_DELEGATE
+ | C_CREATE_CONTRACT
+ | C_CONVERT_TO_LEFT_COMB
+ | C_CONVERT_TO_RIGHT_COMB
+ | C_CONVERT_FROM_LEFT_COMB
+ | C_CONVERT_FROM_RIGHT_COMB
+
+and declaration_loc = declaration location_wrap
+
+and program = declaration_loc list
+
+(* A Declaration_constant is described by
+ * a name + a type-annotated expression
+ * a boolean indicating whether it should be inlined
+ * the environment before the declaration (the original environment)
+ * the environment after the declaration (i.e. with that new declaration added to the original environment). *)
+and declaration_constant = {
+ binder : expression_variable ;
+ expr : expression ;
+ inline : bool ;
+ }
+
+and declaration_type = {
+ type_binder : type_variable ;
+ type_expr : type_expression ;
+ }
+
+and declaration =
+ | Declaration_constant of declaration_constant
+ | Declaration_type of declaration_type
+
+and expression = {
+ expression_content: expression_content ;
+ location: location ;
+ type_expression: type_expression ;
+ }
+
+and map_kv = {
+ k : expression ;
+ v : expression ;
+ }
+
+and look_up = {
+ ds : expression;
+ ind : expression;
+ }
+
+and expression_label_map = expression label_map
+and map_kv_list = map_kv list
+and expression_list = expression list
+
+and expression_content =
+ (* Base *)
+ | E_literal of literal
+ | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
+ | E_variable of expression_variable
+ | E_application of application
+ | E_lambda of lambda
+ | E_recursive of recursive
+ | E_let_in of let_in
+ (* Variant *)
+ | E_constructor of constructor (* For user defined constructors *)
+ | E_matching of matching
+ (* Record *)
+ | E_record of expression_label_map
+ | E_record_accessor of record_accessor
+ | E_record_update of record_update
+
+and constant = {
+ cons_name: constant' ;
+ arguments: expression_list ;
+ }
+
+and application = {
+ lamb: expression ;
+ args: expression ;
+ }
+
+and lambda = {
+ binder: expression_variable ;
+ (* input_type: type_expression option ; *)
+ (* output_type: type_expression option ; *)
+ result: expression ;
+ }
+
+and let_in = {
+ let_binder: expression_variable ;
+ rhs: expression ;
+ let_result: expression ;
+ inline : bool ;
+ }
+
+and recursive = {
+ fun_name : expression_variable;
+ fun_type : type_expression;
+ lambda : lambda;
+}
+
+and constructor = {
+ constructor: constructor';
+ element: expression ;
+ }
+
+and record_accessor = {
+ record: expression ;
+ path: label ;
+ }
+
+and record_update = {
+ record: expression ;
+ path: label ;
+ update: expression ;
+ }
+
+and matching = {
+ matchee: expression ;
+ cases: matching_expr ;
+ }
+
+and ascription = {
+ anno_expr: expression ;
+ type_annotation: type_expression ;
+ }
+
+and environment_element_definition =
+ | ED_binder
+ | ED_declaration of environment_element_definition_declaration
+
+and environment_element_definition_declaration = {
+ expr: expression ;
+ free_variables: free_variables ;
+ }
+
+and free_variables = expression_variable list
+
+and environment_element = {
+ type_value: type_expression ;
+ source_environment: environment ;
+ definition: environment_element_definition ;
+ }
+
+and expression_environment = environment_binding list
+
+and environment_binding = {
+ expr_var: expression_variable ;
+ env_elt: environment_element ;
+ }
+
+and type_environment = type_environment_binding list
+
+and type_environment_binding = {
+ type_variable: type_variable ;
+ type_: type_expression ;
+}
+
+and environment = {
+ expression_environment: expression_environment ;
+ type_environment: type_environment ;
+}
+
+and named_type_content = {
+ type_name : type_variable;
+ type_value : type_expression;
+ }
+
+
+
+
+
+(* Solver types *)
+
+(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *)
+type unionfind = type_variable poly_unionfind
+
+(* core *)
+
+(* add information on the type or the kind for operator *)
+type constant_tag =
+ | C_arrow (* * -> * -> * isn't this wrong? *)
+ | C_option (* * -> * *)
+ | C_record (* ( label , * ) … -> * *)
+ | C_variant (* ( label , * ) … -> * *)
+ | C_map (* * -> * -> * *)
+ | C_big_map (* * -> * -> * *)
+ | C_list (* * -> * *)
+ | C_set (* * -> * *)
+ | C_unit (* * *)
+ | C_string (* * *)
+ | C_nat (* * *)
+ | C_mutez (* * *)
+ | C_timestamp (* * *)
+ | C_int (* * *)
+ | C_address (* * *)
+ | C_bytes (* * *)
+ | C_key_hash (* * *)
+ | C_key (* * *)
+ | C_signature (* * *)
+ | C_operation (* * *)
+ | C_contract (* * -> * *)
+ | C_chain_id (* * *)
+
+(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *)
+type type_value_ =
+ | P_forall of p_forall
+ | P_variable of type_variable
+ | P_constant of p_constant
+ | P_apply of p_apply
+and type_value = {
+ tsrc : string;
+ t : type_value_ ;
+}
+
+and p_apply = {
+ tf : type_value ;
+ targ : type_value ;
+}
+and p_ctor_args = type_value list
+and p_constant = {
+ p_ctor_tag : constant_tag ;
+ p_ctor_args : p_ctor_args ;
+ }
+and p_constraints = type_constraint list
+and p_forall = {
+ binder : type_variable ;
+ constraints : p_constraints ;
+ body : type_value ;
+}
+
+(* Different type of constraint *)
+and ctor_args = type_variable list (* non-empty list *)
+and simple_c_constructor = {
+ ctor_tag : constant_tag ;
+ ctor_args : ctor_args ;
+ }
+and simple_c_constant = {
+ constant_tag: constant_tag ; (* for type constructors that do not take arguments *)
+ }
+and c_const = {
+ c_const_tvar : type_variable ;
+ c_const_tval : type_value ;
+ }
+and c_equation = {
+ aval : type_value ;
+ bval : type_value ;
+}
+and tc_args = type_value list
+and c_typeclass = {
+ tc_args : tc_args ;
+ typeclass : typeclass ;
+}
+and c_access_label = {
+ c_access_label_tval : type_value ;
+ accessor : label ;
+ c_access_label_tvar : type_variable ;
+ }
+
+and type_constraint = {
+ reason : string ;
+ c : type_constraint_ ;
+}
+and type_constraint_ =
+ (* | C_assignment of (type_variable * type_pattern) *)
+ | C_equation of c_equation (* TVA = TVB *)
+ | C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *)
+ | C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *)
+(* | … *)
+
+(* is the first list in case on of the type of the type class as a kind *->*->* ? *)
+and tc_allowed = type_value list
+and typeclass = tc_allowed list
+
+(* end core *)
+
+type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap
+and constraints_typeVariableMap = constraints typeVariableMap
+and type_constraint_simpl_list = type_constraint_simpl list
+and structured_dbs = {
+ all_constraints : type_constraint_simpl_list ;
+ aliases : unionfind ;
+ (* assignments (passive data structure). *)
+ (* Now : just a map from unification vars to types (pb: what about partial types?) *)
+ (* maybe just local assignments (allow only vars as children of pair(α,β)) *)
+ (* TODO : the rhs of the map should not repeat the variable name. *)
+ assignments : c_constructor_simpl_typeVariableMap ;
+ grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *)
+ cycle_detection_toposort : unit ; (* example of structured db that we'll add later *)
+}
+
+and c_constructor_simpl_list = c_constructor_simpl list
+and c_poly_simpl_list = c_poly_simpl list
+and c_typeclass_simpl_list = c_typeclass_simpl list
+and constraints = {
+ (* If implemented in a language with decent sets, these should be sets not lists. *)
+ constructor : c_constructor_simpl_list ; (* List of ('a = constructor(args…)) constraints *)
+ poly : c_poly_simpl_list ; (* List of ('a = forall 'b, some_type) constraints *)
+ tc : c_typeclass_simpl_list ; (* List of (typeclass(args…)) constraints *)
+}
+and type_variable_list = type_variable list
+and c_constructor_simpl = {
+ reason_constr_simpl : string ;
+ tv : type_variable;
+ c_tag : constant_tag;
+ tv_list : type_variable_list;
+}
+and c_const_e = {
+ c_const_e_tv : type_variable ;
+ c_const_e_te : type_expression ;
+ }
+and c_equation_e = {
+ aex : type_expression ;
+ bex : type_expression ;
+ }
+and c_typeclass_simpl = {
+ reason_typeclass_simpl : string ;
+ tc : typeclass ;
+ args : type_variable_list ;
+}
+and c_poly_simpl = {
+ reason_poly_simpl : string ;
+ tv : type_variable ;
+ forall : p_forall ;
+}
+and type_constraint_simpl =
+ | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *)
+ | SC_Alias of c_alias (* α = β *)
+ | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *)
+ | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *)
+
+and c_alias = {
+ reason_alias_simpl : string ;
+ a : type_variable ;
+ b : type_variable ;
+ }
+
+
+(* sub-sub component: lazy selector (don't re-try all selectors every time) *)
+(* For now: just re-try everytime *)
+
+(* selector / propagation rule for breaking down composite types *)
+(* For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
+type output_break_ctor = {
+ a_k_var : c_constructor_simpl ;
+ a_k'_var' : c_constructor_simpl ;
+ }
+
+type output_specialize1 = {
+ poly : c_poly_simpl ;
+ a_k_var : c_constructor_simpl ;
+ }
+
+type m_break_ctor__already_selected = output_break_ctor poly_set
+type m_specialize1__already_selected = output_specialize1 poly_set
+
+type already_selected = {
+ break_ctor : m_break_ctor__already_selected ;
+ specialize1 : m_specialize1__already_selected ;
+}
+
+type typer_state = {
+ structured_dbs : structured_dbs ;
+ already_selected : already_selected ;
+}
diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml
index e78dc9188..b97117f9c 100644
--- a/src/stages/4-ast_typed/ast_typed.ml
+++ b/src/stages/4-ast_typed/ast_typed.ml
@@ -2,9 +2,9 @@ module Types = Types
module Environment = Environment
module PP = PP
module PP_generic = PP_generic
+module Compare_generic = Compare_generic
module Combinators = struct
include Combinators
- include Combinators_environment
end
module Misc = struct
include Misc
@@ -15,3 +15,5 @@ module Helpers = Helpers
include Types
include Misc
include Combinators
+
+let program_environment env program = fst (Compute_environment.program env program)
diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml
index e7959cec7..b423da73d 100644
--- a/src/stages/4-ast_typed/combinators.ml
+++ b/src/stages/4-ast_typed/combinators.ml
@@ -24,10 +24,9 @@ module Errors = struct
end
let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core}
-let make_e ?(location = Location.generated) expression_content type_expression environment = {
+let make_e ?(location = Location.generated) expression_content type_expression = {
expression_content ;
type_expression ;
- environment ;
location ;
}
let make_n_t type_name type_value = { type_name ; type_value }
@@ -83,7 +82,6 @@ let t_shallow_closure param result ?loc ?s () : type_expression = make_t ?loc (T
let get_type_expression (x:expression) = x.type_expression
let get_type' (x:type_expression) = x.type_content
-let get_environment (x:expression) = x.environment
let get_expression (x:expression) = x.expression_content
let get_lambda e : _ result = match e.expression_content with
@@ -330,13 +328,13 @@ let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; le
let e_constructor constructor element: expression_content = E_constructor {constructor;element}
-let e_bool b env : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit()) env)
+let e_bool b : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit()))
let e_a_unit = make_e (e_unit ()) (t_unit ())
let e_a_int n = make_e (e_int n) (t_int ())
let e_a_nat n = make_e (e_nat n) (t_nat ())
let e_a_mutez n = make_e (e_mutez n) (t_mutez ())
-let e_a_bool b = fun env -> make_e (e_bool b env) (t_bool ()) env
+let e_a_bool b = make_e (e_bool b) (t_bool ())
let e_a_string s = make_e (e_string s) (t_string ())
let e_a_address s = make_e (e_address s) (t_address ())
let e_a_pair a b = make_e (e_pair a b)
@@ -381,7 +379,8 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
- | Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name
+ | Declaration_constant { binder ; expr=_ ; inline=_ } -> binder = Var.of_name name
+ | Declaration_type _ -> false
in
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p
diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli
index 192939c72..f4fe615b2 100644
--- a/src/stages/4-ast_typed/combinators.mli
+++ b/src/stages/4-ast_typed/combinators.mli
@@ -3,7 +3,7 @@ open Types
val make_n_t : type_variable -> type_expression -> named_type_content
val make_t : ?loc:Location.t -> type_content -> S.type_expression option -> type_expression
-val make_e : ?location:Location.t -> expression_content -> type_expression -> environment -> expression
+val make_e : ?location:Location.t -> expression_content -> type_expression -> expression
val t_bool : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val t_string : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
@@ -38,7 +38,6 @@ val t_function : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.t
val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val get_type_expression : expression -> type_expression
val get_type' : type_expression -> type_content
-val get_environment : expression -> environment
val get_expression : expression -> expression_content
val get_lambda : expression -> lambda result
val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result
@@ -119,7 +118,7 @@ val e_unit : unit -> expression_content
val e_int : Z.t -> expression_content
val e_nat : Z.t -> expression_content
val e_mutez : Z.t -> expression_content
-val e_bool : bool -> environment -> expression_content
+val e_bool : bool -> expression_content
val e_string : ligo_string -> expression_content
val e_bytes : bytes -> expression_content
val e_timestamp : Z.t -> expression_content
@@ -135,22 +134,22 @@ val e_application : expression -> expression -> expression_content
val e_variable : expression_variable -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
-val e_a_unit : environment -> expression
-val e_a_int : Z.t -> environment -> expression
-val e_a_nat : Z.t -> environment -> expression
-val e_a_mutez : Z.t -> environment -> expression
-val e_a_bool : bool -> environment -> expression
-val e_a_string : ligo_string -> environment -> expression
-val e_a_address : string -> environment -> expression
-val e_a_pair : expression -> expression -> environment -> expression
-val e_a_some : expression -> environment -> expression
-val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression
-val e_a_none : type_expression -> environment -> expression
-val e_a_record : expression label_map -> environment -> expression
-val e_a_application : expression -> expression -> environment -> expression
-val e_a_variable : expression_variable -> type_expression -> environment -> expression
-val ez_e_a_record : ( label * expression ) list -> environment -> expression
-val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> expression
+val e_a_unit : expression
+val e_a_int : Z.t -> expression
+val e_a_nat : Z.t -> expression
+val e_a_mutez : Z.t -> expression
+val e_a_bool : bool -> expression
+val e_a_string : ligo_string -> expression
+val e_a_address : string -> expression
+val e_a_pair : expression -> expression -> expression
+val e_a_some : expression -> expression
+val e_a_lambda : lambda -> type_expression -> type_expression -> expression
+val e_a_none : type_expression -> expression
+val e_a_record : expression label_map -> expression
+val e_a_application : expression -> expression -> expression
+val e_a_variable : expression_variable -> type_expression -> expression
+val ez_e_a_record : ( label * expression ) list -> expression
+val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression
val get_a_int : expression -> Z.t result
val get_a_unit : expression -> unit result
diff --git a/src/stages/4-ast_typed/combinators_environment.ml b/src/stages/4-ast_typed/combinators_environment.ml
deleted file mode 100644
index 78e11ad9a..000000000
--- a/src/stages/4-ast_typed/combinators_environment.ml
+++ /dev/null
@@ -1,25 +0,0 @@
-open Types
-open Combinators
-
-let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty
-
-let e_a_empty_unit = e_a_unit Environment.empty
-let e_a_empty_int n = e_a_int n Environment.empty
-let e_a_empty_nat n = e_a_nat n Environment.empty
-let e_a_empty_mutez n = e_a_mutez n Environment.empty
-let e_a_empty_bool b = e_a_bool b Environment.empty
-let e_a_empty_string s = e_a_string s Environment.empty
-let e_a_empty_address s = e_a_address s Environment.empty
-let e_a_empty_pair a b = e_a_pair a b Environment.empty
-let e_a_empty_some s = e_a_some s Environment.empty
-let e_a_empty_none t = e_a_none t Environment.empty
-let e_a_empty_record r = e_a_record r Environment.empty
-let ez_e_a_empty_record r = ez_e_a_record r Environment.empty
-let e_a_empty_lambda l i o = e_a_lambda l i o Environment.empty
-
-open Environment
-
-let env_sum_type ?(env = empty)
- ?(type_name = Var.of_name "a_sum_type")
- (lst : (constructor' * ctor_content) list) =
- add_type type_name (make_t_ez_sum lst) env
diff --git a/src/stages/4-ast_typed/combinators_environment.mli b/src/stages/4-ast_typed/combinators_environment.mli
deleted file mode 100644
index 64b325975..000000000
--- a/src/stages/4-ast_typed/combinators_environment.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-open Types
-
-val make_a_e_empty : expression_content -> type_expression -> expression
-
-val e_a_empty_unit : expression
-val e_a_empty_int : Z.t -> expression
-val e_a_empty_nat : Z.t -> expression
-val e_a_empty_mutez : Z.t -> expression
-val e_a_empty_bool : bool -> expression
-val e_a_empty_string : ligo_string -> expression
-val e_a_empty_address : string -> expression
-val e_a_empty_pair : expression -> expression -> expression
-val e_a_empty_some : expression -> expression
-val e_a_empty_none : type_expression -> expression
-val e_a_empty_record : expression label_map -> expression
-val ez_e_a_empty_record : ( label * expression ) list -> expression
-val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
-
-val env_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment
diff --git a/src/stages/4-ast_typed/comparable.ml b/src/stages/4-ast_typed/comparable.ml
new file mode 100644
index 000000000..255ed7fbe
--- /dev/null
+++ b/src/stages/4-ast_typed/comparable.ml
@@ -0,0 +1 @@
+include Compare_generic.Comparable
diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml
new file mode 100644
index 000000000..e630f1e3a
--- /dev/null
+++ b/src/stages/4-ast_typed/compare_generic.ml
@@ -0,0 +1,196 @@
+open Types
+open Generated_fold
+
+module M = struct
+ let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *)
+ type 'a lz = unit -> 'a (* Lazy values *)
+ type t =
+ | EmptyCtor
+ | Record of string * (string * t lz) list
+ | VariantConstructor of string * string * t lz
+ | Bool of inline
+ | Bytes of bytes
+ | Constructor' of string
+ | Expression_variable of expression_variable
+ | Int of int
+ | Label' of string
+ | Ligo_string of ligo_string
+ | Location of location
+ | Operation of packed_internal_operation
+ | Str of string
+ | Type_expression of ast_core_type_expression
+ | Unit of unit
+ | Var of type_variable
+ | Z of z
+ | List of t lz list
+ | Location_wrap of t lz Location.wrap
+ | CMap of (constructor' * t lz) list
+ | LMap of (label * t lz) list
+ | UnionFind of t lz list list
+ | Set of t lz list
+ | TypeVariableMap of (type_variable * t lz) list
+
+ type no_state = NoState
+
+ (* TODO: make these functions return a lazy stucture *)
+ let op : (no_state, t) fold_config = {
+ generic = (fun NoState info ->
+ match info.node_instance.instance_kind with
+ | RecordInstance { fields } ->
+ let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) =
+ ( fld.cf.name , fun () -> fld.cf_continue NoState ) in
+ Record ("name_of_the_record", List.map aux fields)
+ | VariantInstance { constructor ; _ } ->
+ VariantConstructor ("name_of_the_variant", constructor.cf.name, fun () -> constructor.cf_continue NoState)
+ | PolyInstance { poly=_; arguments=_; poly_continue } ->
+ poly_continue NoState
+ );
+ generic_empty_ctor = (fun NoState -> EmptyCtor) ;
+ int = (fun _visitor _state i -> Int i );
+ type_variable = (fun _visitor _state type_variable -> Var type_variable) ;
+ bool = (fun _visitor _state b -> Bool b) ;
+ z = (fun _visitor _state i -> Z i) ;
+ string = (fun _visitor _state str -> Str str) ;
+ ligo_string = (fun _visitor _state str -> Ligo_string str) ;
+ bytes = (fun _visitor _state bytes -> Bytes bytes) ;
+ unit = (fun _visitor _state () -> Unit ()) ;
+ packed_internal_operation = (fun _visitor _state op -> Operation op) ;
+ expression_variable = (fun _visitor _state ev -> Expression_variable ev) ;
+ constructor' = (fun _visitor _state (Constructor c) -> Constructor' c) ;
+ location = (fun _visitor _state loc -> Location loc) ;
+ label = (fun _visitor _state (Label lbl) -> Label' lbl) ;
+ ast_core_type_expression = (fun _visitor _state te -> Type_expression te) ;
+ constructor_map = (fun _visitor continue _state cmap ->
+ let kcmp (Constructor a, _) (Constructor b, _) = String.compare a b in
+ let lst = List.sort kcmp (CMap.bindings cmap) in
+ CMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst));
+ label_map = (fun _visitor continue _state lmap ->
+ let kcmp (Label a, _) (Label b, _) = String.compare a b in
+ let lst = List.sort kcmp (LMap.bindings lmap) in
+ LMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst));
+ list = (fun _visitor continue _state lst ->
+ (List (List.map (fun x () -> continue NoState x) lst)));
+ location_wrap = (fun _visitor continue _state lwrap ->
+ let ({ wrap_content; location } : _ Location.wrap) = lwrap in
+ (Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location}));
+ option = (fun _visitor continue _state o ->
+ match o with
+ | None -> VariantConstructor ("built-in:option", "None", fun () -> EmptyCtor)
+ | Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v));
+ poly_unionfind = (fun _visitor continue _state p ->
+ (* UnionFind.Poly2.partitions returns the partitions in a
+ deterministic order, and the elements within a given
+ partition also follow a deterministic order. *)
+ let lst = (UnionFind.Poly2.partitions p) in
+ let aux l = List.map (fun x () -> continue NoState x) l in
+ UnionFind (List.map aux lst));
+ poly_set = (fun _visitor continue _state set ->
+ Set (List.map (fun x () -> continue NoState x) (RedBlackTrees.PolySet.elements set)));
+ typeVariableMap = (fun _visitor continue _state tvmap ->
+ let kcmp (a, _) (b, _) = Var.compare a b in
+ let lst = List.sort kcmp (RedBlackTrees.PolyMap.bindings tvmap) in
+ TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst));
+ }
+
+ let serialize : ((no_state, t) fold_config -> no_state -> 'a -> t) -> 'a -> t = fun fold v ->
+ fold op NoState v
+
+ (* What follows should be roughly the same for all ASTs, so it
+ should be easy to share a single copy of that and of the t type
+ definition above. *)
+
+ (* Generate a unique tag for each case handled below. We can then
+ compare data by their tag and contents. *)
+ let tag = function
+ | EmptyCtor -> 0
+ | Record _ -> 1
+ | VariantConstructor _ -> 2
+ | Bool _ -> 3
+ | Bytes _ -> 4
+ | Constructor' _ -> 5
+ | Expression_variable _ -> 6
+ | Int _ -> 7
+ | Label' _ -> 8
+ | Ligo_string _ -> 9
+ | Location _ -> 10
+ | Operation _ -> 11
+ | Str _ -> 12
+ | Type_expression _ -> 13
+ | Unit _ -> 14
+ | Var _ -> 15
+ | Z _ -> 16
+ | List _ -> 17
+ | Location_wrap _ -> 18
+ | CMap _ -> 19
+ | LMap _ -> 20
+ | UnionFind _ -> 21
+ | Set _ -> 22
+ | TypeVariableMap _ -> 23
+
+ let cmp2 f a1 b1 g a2 b2 = match f a1 b1 with 0 -> g a2 b2 | c -> c
+ let cmp3 f a1 b1 g a2 b2 h a3 b3 = match f a1 b1 with 0 -> (match g a2 b2 with 0 -> h a3 b3 | c -> c) | c -> c
+ let rec compare_field (na, va) (nb, vb) = cmp2 String.compare na nb compare_lz_t va vb
+ and compare_cmap_entry (Constructor na, va) (Constructor nb, vb) = cmp2 String.compare na nb compare_lz_t va vb
+ and compare_lmap_entry (Label na, va) (Label nb, vb) = cmp2 String.compare na nb compare_lz_t va vb
+ and compare_tvmap_entry (tva, va) (tvb, vb) = cmp2 Var.compare tva tvb compare_lz_t va vb
+ and compare_lz_t a b = compare_t (a ()) (b ())
+ and compare_t (a : t) (b : t) =
+ match (a, b) with
+ | (EmptyCtor, EmptyCtor) -> failwith "Should not happen (unless for ctors with no args?)"
+ | (Record (a, fa), Record (b, fb)) -> cmp2 String.compare a b (List.compare ~compare:compare_field) fa fb
+ | (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) ->
+ cmp3
+ String.compare va vb
+ String.compare ca cb
+ compare_lz_t xa xb
+ | (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b
+ | (Bytes a, Bytes b) -> Bytes.compare a b
+ | (Constructor' a, Constructor' b) -> String.compare a b
+ | (Expression_variable a, Expression_variable b) -> Var.compare a b
+ | (Int a, Int b) -> Int.compare a b
+ | (Label' a, Label' b) -> String.compare a b
+ | (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b
+ | (Location a, Location b) -> Location.compare a b
+ | (Operation a, Operation b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for packed_internal_operation ? *)
+ | (Str a, Str b) -> String.compare a b
+ | (Type_expression a, Type_expression b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for ast_core_type_expression ? *)
+ | (Unit (), Unit ()) -> 0
+ | (Var a, Var b) -> Var.compare a b
+ | (Z a, Z b) -> Z.compare a b
+ | (List a, List b) -> List.compare ~compare:compare_lz_t a b
+ | (Location_wrap a, Location_wrap b) -> Location.compare_wrap ~compare:compare_lz_t a b
+ | (CMap a, CMap b) -> List.compare ~compare:compare_cmap_entry a b
+ | (LMap a, LMap b) -> List.compare ~compare:compare_lmap_entry a b
+ | (UnionFind a, UnionFind b) -> List.compare ~compare:(List.compare ~compare:compare_lz_t) a b
+ | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b
+ | (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b
+
+ | ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a),
+ ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) ->
+ Int.compare (tag a) (tag b)
+
+
+ let mk_compare : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a -> 'a -> int = fun fold a b ->
+ compare_t (serialize fold a) (serialize fold b)
+
+ let mk_comparable : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a extra_info__comparable = fun fold ->
+ { compare = mk_compare fold }
+end
+
+(* Generate a comparison function for each type, named like the type itself. *)
+include Folds(struct
+ type in_state = M.no_state ;;
+ type out_state = M.t ;;
+ type 'a t = 'a -> 'a -> int ;;
+ let f = M.mk_compare ;;
+end)
+
+module Comparable = struct
+ (* Generate a comparator typeclass-like object for each type, named like the type itself. *)
+ include Folds(struct
+ type in_state = M.no_state ;;
+ type out_state = M.t ;;
+ type 'a t = 'a extra_info__comparable ;;
+ let f = M.mk_comparable ;;
+ end)
+end
diff --git a/src/passes/9-self_ast_typed/recompute_environment.ml b/src/stages/4-ast_typed/compute_environment.ml
similarity index 75%
rename from src/passes/9-self_ast_typed/recompute_environment.ml
rename to src/stages/4-ast_typed/compute_environment.ml
index 4124038c2..ce4013a28 100644
--- a/src/passes/9-self_ast_typed/recompute_environment.ml
+++ b/src/stages/4-ast_typed/compute_environment.ml
@@ -1,23 +1,9 @@
-open Ast_typed
-
-(*
- During the modifications of the passes on `Ast_typed`, the binding
- environments are not kept in sync. To palliate this, this module
- recomputes them from scratch.
-*)
-
-(*
- This module is very coupled to `typer.ml`. Given environments are
- not used until the next pass, it makes sense to split this into
- its own separate pass. This pass would go from `Ast_typed` without
- environments to `Ast_typed` with embedded environments.
-*)
+open Types
let rec expression : environment -> expression -> expression = fun env expr ->
(* Standard helper functions to help with the fold *)
- let return ?(env' = env) content = {
+ let return content = {
expr with
- environment = env' ;
expression_content = content ;
} in
let return_id = return expr.expression_content in
@@ -34,9 +20,9 @@ let rec expression : environment -> expression -> expression = fun env expr ->
return @@ E_lambda { c with result }
)
| E_let_in c -> (
- let env' = Environment.add_ez_declaration c.let_binder c.rhs env in
- let let_result = self ~env' c.let_result in
let rhs = self c.rhs in
+ let env' = Environment.add_ez_declaration c.let_binder rhs env in
+ let let_result = self ~env' c.let_result in
return @@ E_let_in { c with rhs ; let_result }
)
(* rec fun_name binder -> result *)
@@ -90,7 +76,7 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
let match_cons =
let mc = c.match_cons in
let env_hd = Environment.add_ez_binder mc.hd mc.tv env in
- let env_tl = Environment.add_ez_binder mc.tl (t_list mc.tv ()) env_hd in
+ let env_tl = Environment.add_ez_binder mc.tl (Combinators.t_list mc.tv ()) env_hd in
let body = self ~env':env_tl mc.body in
{ mc with body }
in
@@ -139,24 +125,27 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
return @@ Match_variant { c with cases }
)
-let program : environment -> program -> program = fun init_env prog ->
+let program : environment -> program -> environment * program = fun init_env prog ->
(*
BAD
We take the old type environment and add it to the current value environment
because type declarations are removed in the typer. They should be added back.
*)
- let merge old_env re_env = {
- expression_environment = re_env.expression_environment ;
- type_environment = old_env.type_environment ;
- } in
let aux (pre_env , rev_decls) decl_wrapped =
- let (Declaration_constant c) = Location.unwrap decl_wrapped in
- let expr = expression pre_env c.expr in
- let post_env = Environment.add_ez_declaration c.binder c.expr pre_env in
- let post_env' = merge c.post_env post_env in
- let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in
- let decl_wrapped' = { decl_wrapped with wrap_content } in
- (post_env , decl_wrapped' :: rev_decls)
+ match Location.unwrap decl_wrapped with
+ | Declaration_constant c -> (
+ let expr = expression pre_env c.expr in
+ let post_env = Environment.add_ez_declaration c.binder expr pre_env in
+ let wrap_content = Declaration_constant { c with expr } in
+ let decl_wrapped' = { decl_wrapped with wrap_content } in
+ (post_env , decl_wrapped' :: rev_decls)
+ )
+ | Declaration_type t -> (
+ let post_env = Environment.add_type t.type_binder t.type_expr pre_env in
+ let wrap_content = Declaration_type t in
+ let decl_wrapped' = { decl_wrapped with wrap_content } in
+ (post_env , decl_wrapped' :: rev_decls)
+ )
in
- let (_last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
- List.rev rev_decls
+ let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
+ (last_env , List.rev rev_decls)
diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune
index 874a19c0a..b2993c400 100644
--- a/src/stages/4-ast_typed/dune
+++ b/src/stages/4-ast_typed/dune
@@ -1,7 +1,7 @@
(rule
- (target generated_fold.ml)
- (deps ../adt_generator/generator.raku types.ml)
- (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml)))
+ (targets generated_fold.ml generated_map.ml generated_o.ml)
+ (deps ../adt_generator/generator.raku ast.ml)
+ (action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml))
(mode (promote (until-clean) (only *)))
)
@@ -19,5 +19,6 @@
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
+;; (modules_without_implementation generated_fold_x)
(flags (:standard -open Simple_utils))
)
diff --git a/src/stages/4-ast_typed/environment.ml b/src/stages/4-ast_typed/environment.ml
index 30e59ebab..0b9457466 100644
--- a/src/stages/4-ast_typed/environment.ml
+++ b/src/stages/4-ast_typed/environment.ml
@@ -38,6 +38,9 @@ let add_ez_binder : expression_variable -> type_expression -> t -> t = fun k v e
let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e ->
add_expr k (make_element_declaration e ae) e
+let add_ez_sum_type ?(env = empty) ?(type_name = Var.of_name "a_sum_type") (lst : (constructor' * ctor_content) list) =
+ add_type type_name (make_t_ez_sum lst) env
+
let convert_constructor' (S.Constructor c) = Constructor c
let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)
@@ -76,4 +79,4 @@ module PP = struct
expr_environment (get_expr_environment e)
type_environment (get_type_environment e)
-end
\ No newline at end of file
+end
diff --git a/src/stages/4-ast_typed/environment.mli b/src/stages/4-ast_typed/environment.mli
index 6b3fb52e2..d73279d85 100644
--- a/src/stages/4-ast_typed/environment.mli
+++ b/src/stages/4-ast_typed/environment.mli
@@ -11,6 +11,7 @@ val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option
+val add_ez_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment
module PP : sig
open Format
diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml
index 271974820..cc02b5fba 100644
--- a/src/stages/4-ast_typed/fold.ml
+++ b/src/stages/4-ast_typed/fold.ml
@@ -1 +1,3 @@
include Generated_fold
+include Generated_map
+include Generated_o
diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml
index a3df9718f..537a734f3 100644
--- a/src/stages/4-ast_typed/misc.ml
+++ b/src/stages/4-ast_typed/misc.ml
@@ -511,28 +511,35 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@
- let aux x =
- let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in
- if Var.equal binder (Var.of_name name)
- then Some expr
- else None
+ let aux x =
+ match Location.unwrap x with
+ | Declaration_constant { binder ; expr ; inline=_ } -> (
+ if Var.equal binder (Var.of_name name)
+ then Some expr
+ else None
+ )
+ | Declaration_type _ -> None
in
List.find_map aux lst
-let program_environment (program : program) : environment =
- let last_declaration = Location.unwrap List.(hd @@ rev program) in
- match last_declaration with
- | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env
-
let equal_variables a b : bool =
match a.expression_content, b.expression_content with
| E_variable a, E_variable b -> Var.equal a b
| _, _ -> false
-let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) =
- P_constant {
+let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = {
+ tsrc = "misc.ml/p_constant" ;
+ t = P_constant {
p_ctor_tag : constant_tag ;
p_ctor_args : p_ctor_args ;
}
+}
let c_equation aval bval reason = { c = C_equation { aval ; bval }; reason }
+
+let reason_simpl : type_constraint_simpl -> string = function
+ | SC_Constructor { reason_constr_simpl=reason; _ }
+ | SC_Alias { reason_alias_simpl=reason; _ }
+ | SC_Poly { reason_poly_simpl=reason; _ }
+ | SC_Typeclass { reason_typeclass_simpl=reason; _ }
+ -> reason
diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli
index ae0bb692f..71bb8a291 100644
--- a/src/stages/4-ast_typed/misc.mli
+++ b/src/stages/4-ast_typed/misc.mli
@@ -70,7 +70,8 @@ val assert_literal_eq : ( literal * literal ) -> unit result
*)
val get_entry : program -> string -> expression result
-val program_environment : program -> environment
val p_constant : constant_tag -> p_ctor_args -> type_value
val c_equation : type_value -> type_value -> string -> type_constraint
+
+val reason_simpl : type_constraint_simpl -> string
diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml
index a09ed2acc..d62665149 100644
--- a/src/stages/4-ast_typed/misc_smart.ml
+++ b/src/stages/4-ast_typed/misc_smart.ml
@@ -8,8 +8,9 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
- | Declaration_constant { binder; expr; inline=_ ; post_env=_ } when binder = Var.of_name s -> Some expr
+ | Declaration_constant { binder; expr; inline=_ } when binder = Var.of_name s -> Some expr
| Declaration_constant _ -> None
+ | Declaration_type _ -> None
in
let%bind main =
trace_option (simple_error "no main with given name") @@
@@ -20,16 +21,11 @@ let program_to_main : program -> string -> lambda result = fun p s ->
| _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty)
in
- let env =
- let aux = fun _ d ->
- match d with
- | Declaration_constant {binder=_ ; expr= _ ; inline=_ ; post_env } -> post_env in
- List.fold_left aux Environment.empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in
let result =
- let input_expr = e_a_variable binder input_type env in
- let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
- e_a_application main_expr input_expr env in
+ let input_expr = e_a_variable binder input_type in
+ let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in
+ e_a_application main_expr input_expr in
ok {
binder ;
result ;
@@ -46,8 +42,8 @@ module Captured_variables = struct
let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings result = fun b e ->
- expression_content b e.environment e.expression_content
- and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec ->
+ expression_content b e.expression_content
+ and expression_content : bindings -> expression_content -> bindings result = fun b ec ->
let self = expression b in
match ec with
| E_lambda l -> ok @@ Free_variables.lambda empty l
@@ -56,12 +52,7 @@ module Captured_variables = struct
let%bind lst' = bind_map_list self arguments in
ok @@ unions lst'
| E_variable name -> (
- let%bind env_element =
- trace_option (simple_error "missing var in env") @@
- Environment.get_opt name env in
- match env_element.definition with
- | ED_binder -> ok empty
- | ED_declaration {expr=_ ; free_variables=_} -> simple_fail "todo"
+ if mem name b then ok empty else ok (singleton name)
)
| E_application {lamb;args} ->
let%bind lst' = bind_map_list self [ lamb ; args ] in
@@ -84,7 +75,7 @@ module Captured_variables = struct
expression b' li.let_result
| E_recursive r ->
let b' = union (singleton r.fun_name) b in
- expression_content b' env @@ E_lambda r.lambda
+ expression_content b' @@ E_lambda r.lambda
and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body
diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml
index be7a7a287..6f4ee13b2 100644
--- a/src/stages/4-ast_typed/types.ml
+++ b/src/stages/4-ast_typed/types.ml
@@ -1,615 +1,5 @@
-[@@@warning "-30"]
-
+(* The content of types.ml has been split into Ast which contains only
+ type declarations, and Types_utils which contains some alias
+ declarations and other definitions used by the fold generator. *)
include Types_utils
-
-type type_constant =
- | TC_unit
- | TC_string
- | TC_bytes
- | TC_nat
- | TC_int
- | TC_mutez
- | TC_operation
- | TC_address
- | TC_key
- | TC_key_hash
- | TC_chain_id
- | TC_signature
- | TC_timestamp
- | TC_void
-
-type te_cmap = ctor_content constructor_map
-and te_lmap = field_content label_map
-and type_meta = ast_core_type_expression option
-
-and type_content =
- | T_sum of te_cmap
- | T_record of te_lmap
- | T_arrow of arrow
- | T_variable of type_variable
- | T_constant of type_constant
- | T_operator of type_operator
-
-and arrow = {
- type1: type_expression;
- type2: type_expression;
- }
-
-and annot_option = string option
-
-and ctor_content = {
- ctor_type : type_expression;
- michelson_annotation : annot_option;
- ctor_decl_pos : int;
-}
-
-and field_content = {
- field_type : type_expression;
- michelson_annotation : annot_option;
- field_decl_pos : int;
-}
-
-and type_map_args = {
- k : type_expression;
- v : type_expression;
- }
-
-and michelson_or_args = {
- l : type_expression;
- r : type_expression;
- }
-
-and type_operator =
- | TC_contract of type_expression
- | TC_option of type_expression
- | TC_list of type_expression
- | TC_set of type_expression
- | TC_map of type_map_args
- | TC_big_map of type_map_args
- | TC_map_or_big_map of type_map_args
-
-and type_expression = {
- type_content: type_content;
- type_meta: type_meta;
- location: location;
- }
-
-type literal =
- | Literal_unit
- | Literal_int of z
- | Literal_nat of z
- | Literal_timestamp of z
- | Literal_mutez of z
- | Literal_string of ligo_string
- | Literal_bytes of bytes
- | Literal_address of string
- | Literal_signature of string
- | Literal_key of string
- | Literal_key_hash of string
- | Literal_chain_id of string
- | Literal_void
- | Literal_operation of packed_internal_operation
-
-
-and matching_content_cons = {
- hd : expression_variable;
- tl : expression_variable;
- body : expression;
- tv : type_expression;
- }
-
-and matching_content_list = {
- match_nil : expression ;
- match_cons : matching_content_cons;
- }
-
-and matching_content_some = {
- opt : expression_variable ;
- body : expression ;
- tv : type_expression ;
- }
-
-and matching_content_option = {
- match_none : expression ;
- match_some : matching_content_some ;
- }
-
-and expression_variable_list = expression_variable list
-and type_expression_list = type_expression list
-
-and matching_content_tuple = {
- vars : expression_variable_list ;
- body : expression ;
- tvs : type_expression_list ;
- }
-
-and matching_content_case = {
- constructor : constructor' ;
- pattern : expression_variable ;
- body : expression ;
- }
-
-and matching_content_case_list = matching_content_case list
-
-and matching_content_variant = {
- cases: matching_content_case_list;
- tv: type_expression;
- }
-
-and matching_expr =
- | Match_list of matching_content_list
- | Match_option of matching_content_option
- | Match_tuple of matching_content_tuple
- | Match_variant of matching_content_variant
-
-and constant' =
- | C_INT
- | C_UNIT
- | C_NIL
- | C_NOW
- | C_IS_NAT
- | C_SOME
- | C_NONE
- | C_ASSERTION
- | C_ASSERT_INFERRED
- | C_FAILWITH
- | C_UPDATE
- (* Loops *)
- | C_ITER
- | C_FOLD_WHILE
- | C_FOLD_CONTINUE
- | C_FOLD_STOP
- | C_LOOP_LEFT
- | C_LOOP_CONTINUE
- | C_LOOP_STOP
- | C_FOLD
- (* MATH *)
- | C_NEG
- | C_ABS
- | C_ADD
- | C_SUB
- | C_MUL
- | C_EDIV
- | C_DIV
- | C_MOD
- (* LOGIC *)
- | C_NOT
- | C_AND
- | C_OR
- | C_XOR
- | C_LSL
- | C_LSR
- (* COMPARATOR *)
- | C_EQ
- | C_NEQ
- | C_LT
- | C_GT
- | C_LE
- | C_GE
- (* Bytes/ String *)
- | C_SIZE
- | C_CONCAT
- | C_SLICE
- | C_BYTES_PACK
- | C_BYTES_UNPACK
- | C_CONS
- (* Pair *)
- | C_PAIR
- | C_CAR
- | C_CDR
- | C_LEFT
- | C_RIGHT
- (* Set *)
- | C_SET_EMPTY
- | C_SET_LITERAL
- | C_SET_ADD
- | C_SET_REMOVE
- | C_SET_ITER
- | C_SET_FOLD
- | C_SET_MEM
- (* List *)
- | C_LIST_EMPTY
- | C_LIST_LITERAL
- | C_LIST_ITER
- | C_LIST_MAP
- | C_LIST_FOLD
- (* Maps *)
- | C_MAP
- | C_MAP_EMPTY
- | C_MAP_LITERAL
- | C_MAP_GET
- | C_MAP_GET_FORCE
- | C_MAP_ADD
- | C_MAP_REMOVE
- | C_MAP_UPDATE
- | C_MAP_ITER
- | C_MAP_MAP
- | C_MAP_FOLD
- | C_MAP_MEM
- | C_MAP_FIND
- | C_MAP_FIND_OPT
- (* Big Maps *)
- | C_BIG_MAP
- | C_BIG_MAP_EMPTY
- | C_BIG_MAP_LITERAL
- (* Crypto *)
- | C_SHA256
- | C_SHA512
- | C_BLAKE2b
- | C_HASH
- | C_HASH_KEY
- | C_CHECK_SIGNATURE
- | C_CHAIN_ID
- (* Blockchain *)
- | C_CALL
- | C_CONTRACT
- | C_CONTRACT_OPT
- | C_CONTRACT_ENTRYPOINT
- | C_CONTRACT_ENTRYPOINT_OPT
- | C_AMOUNT
- | C_BALANCE
- | C_SOURCE
- | C_SENDER
- | C_ADDRESS
- | C_SELF
- | C_SELF_ADDRESS
- | C_IMPLICIT_ACCOUNT
- | C_SET_DELEGATE
- | C_CREATE_CONTRACT
- | C_CONVERT_TO_LEFT_COMB
- | C_CONVERT_TO_RIGHT_COMB
- | C_CONVERT_FROM_LEFT_COMB
- | C_CONVERT_FROM_RIGHT_COMB
-
-and declaration_loc = declaration location_wrap
-
-and program = declaration_loc list
-
-and declaration_constant = {
- binder : expression_variable ;
- expr : expression ;
- inline : bool ;
- post_env : environment ;
- }
-
-and declaration =
- (* A Declaration_constant is described by
- * a name + a type-annotated expression
- * a boolean indicating whether it should be inlined
- * the environment before the declaration (the original environment)
- * the environment after the declaration (i.e. with that new declaration added to the original environment). *)
- | Declaration_constant of declaration_constant
- (*
- | Declaration_type of (type_variable * type_expression)
- | Declaration_constant of (named_expression * (environment * environment))
- *)
-(* | Macro_declaration of macro_declaration *)
-
-and expression = {
- expression_content: expression_content ;
- location: location ;
- type_expression: type_expression ;
- environment: environment ;
- }
-
-and map_kv = {
- k : expression ;
- v : expression ;
- }
-
-and look_up = {
- ds : expression;
- ind : expression;
- }
-
-and expression_label_map = expression label_map
-and map_kv_list = map_kv list
-and expression_list = expression list
-
-and expression_content =
- (* Base *)
- | E_literal of literal
- | E_constant of constant (* For language constants, like (Cons hd tl) or (plus i j) *)
- | E_variable of expression_variable
- | E_application of application
- | E_lambda of lambda
- | E_recursive of recursive
- | E_let_in of let_in
- (* Variant *)
- | E_constructor of constructor (* For user defined constructors *)
- | E_matching of matching
- (* Record *)
- | E_record of expression_label_map
- | E_record_accessor of record_accessor
- | E_record_update of record_update
-
-and constant = {
- cons_name: constant' ;
- arguments: expression_list ;
- }
-
-and application = {
- lamb: expression ;
- args: expression ;
- }
-
-and lambda = {
- binder: expression_variable ;
- (* input_type: type_expression option ; *)
- (* output_type: type_expression option ; *)
- result: expression ;
- }
-
-and let_in = {
- let_binder: expression_variable ;
- rhs: expression ;
- let_result: expression ;
- inline : bool ;
- }
-
-and recursive = {
- fun_name : expression_variable;
- fun_type : type_expression;
- lambda : lambda;
-}
-
-and constructor = {
- constructor: constructor';
- element: expression ;
- }
-
-and record_accessor = {
- record: expression ;
- path: label ;
- }
-
-and record_update = {
- record: expression ;
- path: label ;
- update: expression ;
- }
-
-and matching = {
- matchee: expression ;
- cases: matching_expr ;
- }
-
-and ascription = {
- anno_expr: expression ;
- type_annotation: type_expression ;
- }
-
-and environment_element_definition =
- | ED_binder
- | ED_declaration of environment_element_definition_declaration
-
-and environment_element_definition_declaration = {
- expr: expression ;
- free_variables: free_variables ;
- }
-
-and free_variables = expression_variable list
-
-and environment_element = {
- type_value: type_expression ;
- source_environment: environment ;
- definition: environment_element_definition ;
- }
-
-and expression_environment = environment_binding list
-
-and environment_binding = {
- expr_var: expression_variable ;
- env_elt: environment_element ;
- }
-
-and type_environment = type_environment_binding list
-
-and type_environment_binding = {
- type_variable: type_variable ;
- type_: type_expression ;
-}
-
-and environment = {
- expression_environment: expression_environment ;
- type_environment: type_environment ;
-}
-
-and named_type_content = {
- type_name : type_variable;
- type_value : type_expression;
- }
-
-
-
-
-
-(* Solver types *)
-
-(* typevariable: to_string = (fun s -> Format.asprintf "%a" Var.pp s) *)
-type unionfind = type_variable poly_unionfind
-
-(* core *)
-
-(* add information on the type or the kind for operator *)
-type constant_tag =
- | C_arrow (* * -> * -> * isn't this wrong? *)
- | C_option (* * -> * *)
- | C_record (* ( label , * ) … -> * *)
- | C_variant (* ( label , * ) … -> * *)
- | C_map (* * -> * -> * *)
- | C_big_map (* * -> * -> * *)
- | C_list (* * -> * *)
- | C_set (* * -> * *)
- | C_unit (* * *)
- | C_string (* * *)
- | C_nat (* * *)
- | C_mutez (* * *)
- | C_timestamp (* * *)
- | C_int (* * *)
- | C_address (* * *)
- | C_bytes (* * *)
- | C_key_hash (* * *)
- | C_key (* * *)
- | C_signature (* * *)
- | C_operation (* * *)
- | C_contract (* * -> * *)
- | C_chain_id (* * *)
-
-(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *)
-type type_value =
- | P_forall of p_forall
- | P_variable of type_variable
- | P_constant of p_constant
- | P_apply of p_apply
-
-and p_apply = {
- tf : type_value ;
- targ : type_value ;
-}
-and p_ctor_args = type_value list
-and p_constant = {
- p_ctor_tag : constant_tag ;
- p_ctor_args : p_ctor_args ;
- }
-and p_constraints = type_constraint list
-and p_forall = {
- binder : type_variable ;
- constraints : p_constraints ;
- body : type_value ;
-}
-
-(* Different type of constraint *)
-and ctor_args = type_variable list (* non-empty list *)
-and simple_c_constructor = {
- ctor_tag : constant_tag ;
- ctor_args : ctor_args ;
- }
-and simple_c_constant = {
- constant_tag: constant_tag ; (* for type constructors that do not take arguments *)
- }
-and c_const = {
- c_const_tvar : type_variable ;
- c_const_tval : type_value ;
- }
-and c_equation = {
- aval : type_value ;
- bval : type_value ;
-}
-and tc_args = type_value list
-and c_typeclass = {
- tc_args : tc_args ;
- typeclass : typeclass ;
-}
-and c_access_label = {
- c_access_label_tval : type_value ;
- accessor : label ;
- c_access_label_tvar : type_variable ;
- }
-
-and type_constraint = {
- reason : string ;
- c : type_constraint_ ;
-}
-and type_constraint_ =
- (* | C_assignment of (type_variable * type_pattern) *)
- | C_equation of c_equation (* TVA = TVB *)
- | C_typeclass of c_typeclass (* TVL ∈ TVLs, for now in extension, later add intensional (rule-based system for inclusion in the typeclass) *)
- | C_access_label of c_access_label (* poor man's type-level computation to ensure that TV.label is type_variable *)
-(* | … *)
-
-(* is the first list in case on of the type of the type class as a kind *->*->* ? *)
-and tc_allowed = type_value list
-and typeclass = tc_allowed list
-
-(* end core *)
-
-type c_constructor_simpl_typeVariableMap = c_constructor_simpl typeVariableMap
-and constraints_typeVariableMap = constraints typeVariableMap
-and type_constraint_simpl_list = type_constraint_simpl list
-and structured_dbs = {
- all_constraints : type_constraint_simpl_list ;
- aliases : unionfind ;
- (* assignments (passive data structure). *)
- (* Now : just a map from unification vars to types (pb: what about partial types?) *)
- (* maybe just local assignments (allow only vars as children of pair(α,β)) *)
- (* TODO : the rhs of the map should not repeat the variable name. *)
- assignments : c_constructor_simpl_typeVariableMap ;
- grouped_by_variable : constraints_typeVariableMap ; (* map from (unionfind) variables to constraints containing them *)
- cycle_detection_toposort : unit ; (* example of structured db that we'll add later *)
-}
-
-and c_constructor_simpl_list = c_constructor_simpl list
-and c_poly_simpl_list = c_poly_simpl list
-and c_typeclass_simpl_list = c_typeclass_simpl list
-and constraints = {
- (* If implemented in a language with decent sets, these should be sets not lists. *)
- constructor : c_constructor_simpl_list ; (* List of ('a = constructor(args…)) constraints *)
- poly : c_poly_simpl_list ; (* List of ('a = forall 'b, some_type) constraints *)
- tc : c_typeclass_simpl_list ; (* List of (typeclass(args…)) constraints *)
-}
-and type_variable_list = type_variable list
-and c_constructor_simpl = {
- tv : type_variable;
- c_tag : constant_tag;
- tv_list : type_variable_list;
-}
-and c_const_e = {
- c_const_e_tv : type_variable ;
- c_const_e_te : type_expression ;
- }
-and c_equation_e = {
- aex : type_expression ;
- bex : type_expression ;
- }
-and c_typeclass_simpl = {
- tc : typeclass ;
- args : type_variable_list ;
-}
-and c_poly_simpl = {
- tv : type_variable ;
- forall : p_forall ;
-}
-and type_constraint_simpl = {
- reason_simpl : string ;
- c_simpl : type_constraint_simpl_ ;
- }
-and type_constraint_simpl_ =
- | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *)
- | SC_Alias of c_alias (* α = β *)
- | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *)
- | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *)
-
-and c_alias = {
- a : type_variable ;
- b : type_variable ;
- }
-
-
-(* sub-sub component: lazy selector (don't re-try all selectors every time) *)
-(* For now: just re-try everytime *)
-
-(* selector / propagation rule for breaking down composite types *)
-(* For now: break pair(a, b) = pair(c, d) into a = c, b = d *)
-type output_break_ctor = {
- a_k_var : c_constructor_simpl ;
- a_k'_var' : c_constructor_simpl ;
- }
-
-type output_specialize1 = {
- poly : c_poly_simpl ;
- a_k_var : c_constructor_simpl ;
- }
-
-type m_break_ctor__already_selected = output_break_ctor poly_set
-type m_specialize1__already_selected = output_specialize1 poly_set
-
-type already_selected = {
- break_ctor : m_break_ctor__already_selected ;
- specialize1 : m_specialize1__already_selected ;
-}
-
-type typer_state = {
- structured_dbs : structured_dbs ;
- already_selected : already_selected ;
-}
+include Ast
diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml
index 2c77f5c7d..8b6138f56 100644
--- a/src/stages/4-ast_typed/types_utils.ml
+++ b/src/stages/4-ast_typed/types_utils.ml
@@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe
type location = Location.t
type inline = bool
+type 'a extra_info__comparable = {
+ compare : 'a -> 'a -> int ;
+}
+
let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result =
fun f state m ->
let aux k v acc =
@@ -93,9 +97,9 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t
type 'a poly_set = 'a RedBlackTrees.PolySet.t
-let fold_map__poly_unionfind : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
- fun f state l ->
- ignore (f, state, l) ; failwith "TODO
+let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
+ fun extra_info f state l ->
+ ignore (extra_info, f, state, l) ; failwith "TODO
let aux acc element =
let%bind state , l = acc in
let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
@@ -114,9 +118,9 @@ let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) re
let fold_map__typeVariableMap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap) result =
fold_map__PolyMap
-let fold_map__poly_set : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
- fun f state s ->
- let new_compare : (new_a -> new_a -> int) = failwith "TODO: thread enough information about the target AST so that we may compare things here." in
+let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
+ fun extra_info f state s ->
+ let new_compare : (new_a -> new_a -> int) = extra_info.compare in
let aux elt ~acc =
let%bind (state , s) = acc in
let%bind (state , new_elt) = f state elt in
diff --git a/src/stages/5-mini_c/combinators.ml b/src/stages/5-mini_c/combinators.ml
index ff421421c..f01eda745 100644
--- a/src/stages/5-mini_c/combinators.ml
+++ b/src/stages/5-mini_c/combinators.ml
@@ -183,6 +183,15 @@ let e_let_in ?loc v tv inline expr body : expression = Expression.(make_tpl ?loc
E_let_in ((v , tv) , inline, expr , body) ,
get_type body
))
+let e_application ?loc f t arg: expression = Expression.(make_tpl ?loc(
+ E_application (f,arg) ,
+ t
+ ))
+let e_var ?loc vname t: expression = Expression.(make_tpl ?loc(
+ E_variable vname ,
+ t
+ ))
+
let ez_e_sequence ?loc a b : expression = Expression.(make_tpl (E_sequence (make_tpl ?loc (a , t_unit ()) , b) , get_type b))
diff --git a/src/stages/5-mini_c/combinators.mli b/src/stages/5-mini_c/combinators.mli
index f198e8b8e..3a9aab3ed 100644
--- a/src/stages/5-mini_c/combinators.mli
+++ b/src/stages/5-mini_c/combinators.mli
@@ -78,3 +78,5 @@ val d_unit : value
val environment_wrap : environment -> environment -> environment_wrap
val id_environment_wrap : environment -> environment_wrap
+val e_var : ?loc:Location.t -> var_name -> type_expression -> expression
+val e_application : ?loc:Location.t -> expression -> type_expression -> expression -> expression
diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku
index 8b323c157..aa5de686b 100644
--- a/src/stages/adt_generator/generator.raku
+++ b/src/stages/adt_generator/generator.raku
@@ -8,17 +8,27 @@ use worries;
# TODO: shorthand for `foo list` etc. in field and constructor types
# TODO: error when reserved names are used ("state", … please list them here)
-my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_");
+my $inputADTfile = @*ARGS[0];
+my $oModuleName = @*ARGS[1];
+my $combinators_filename = @*ARGS[2];
+my $folder_filename = @*ARGS[3];
+my $mapper_filename = @*ARGS[4];
+
+my $moduleName = $inputADTfile.subst(/\.ml$/, '').samecase("A_");
my $variant = "_ _variant";
my $record = "_ _ record";
sub poly { $^type_name }
-my $l = @*ARGS[0].IO.lines;
+my $l = $inputADTfile.IO.lines;
$l = $l.map(*.subst: /(^\s+|\s+$)/, "");
$l = $l.list.cache;
my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/;
my $statements = $l.grep($statement_re);
$l = $l.grep(none $statement_re);
+$l = $l.list.cache;
+my $typeclass_re = /^\(\*\@ \s* typeclass \s+ (\w+) \s+ (\w+) \s* \*\)/;
+my $typeclasses = %($l.grep($typeclass_re).map({ do given $_ { when $typeclass_re { %{ "$/[0]" => "$/[1]" } } } }).flat);
+$l = $l.grep(none $typeclass_re);
$statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, ''));
$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
# TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose.
@@ -50,424 +60,452 @@ $l = $l.map: {
"kind" => $kind ,
"ctorsOrFields" => $ctorsOrFields
}
- # $_[0].subst: , '' }
};
-# $l.perl.say;
-# exit;
-
-# ($cf, $isBuiltin, $type)
- # {
- # name => $cf ,
- # newName => "$cf'" ,
- # isBuiltin => $isBuiltin ,
- # type => $type ,
- # newType => $isBuiltin ?? $type !! "$type'"
- # }
-
-
-
-# my @adts_raw = [
-# # typename, kind, fields_or_ctors
-# ["root", $variant, [
-# # ctor, builtin?, type
-# ["A", False, "rootA"],
-# ["B", False, "rootB"],
-# ["C", True, "string"],
-# ]],
-# ["a", $record, [
-# # field, builtin?, type
-# ["a1", False, "ta1"],
-# ["a2", False, "ta2"],
-# ]],
-# ["ta1", $variant, [
-# ["X", False, "root"],
-# ["Y", False, "ta2"],
-# ]],
-# ["ta2", $variant, [
-# ["Z", False, "ta2"],
-# ["W", True, "unit"],
-# ]],
-# # polymorphic type
-# ["rootA", poly("list"),
-# [
-# # Position (0..n-1), builtin?, type argument
-# [0, False, "a"],
-# ],
-# ],
-# ["rootB", poly("list"),
-# [
-# # Position (0..n-1), builtin?, type argument
-# [0, True, "int"],
-# ],
-# ],
-# ];
-
-# # say $adts_raw.perl;
-# my $adts = (map -> ($name , $kind, @ctorsOrFields) {
-# {
-# "name" => $name ,
-# "newName" => "$name'" ,
-# "kind" => $kind ,
-# "ctorsOrFields" => @(map -> ($cf, $isBuiltin, $type) {
-# {
-# name => $cf ,
-# newName => "$cf'" ,
-# isBuiltin => $isBuiltin ,
-# type => $type ,
-# newType => $isBuiltin ?? $type !! "$type'"
-# }
-# }, @ctorsOrFields),
-# }
-# }, @adts_raw).list;
my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
{
"name" => $name ,
- "newName" => "{$name}__'" ,
+ "oNewName" => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}",
+ "newName" => $name ,
"kind" => $kind ,
"ctorsOrFields" => @(map -> ($cf, $type) {
- my $isBuiltin = (! $type) || (! $l.cache.first({ $_ eq $type }));
+ my $resolvedType = $type && $l.cache.first({ $_ eq $type });
+ my $isBuiltin = (! $type) || (! $resolvedType);
+ # my $isPoly = $resolvedType && $resolvedType ne $record && $resolvedType ne $variant;
{
name => $cf ,
- newName => "{$cf}__'" ,
+ oNewName => "O.{$cf}" ,
+ newName => $cf ,
isBuiltin => $isBuiltin ,
type => $type ,
- newType => $isBuiltin ?? "$type" !! "{$type}__'"
+ oNewType => $isBuiltin ?? "$type" !! "O.{$type}" ,
+ newType => $type ,
}
}, @ctorsOrFields),
}
}, @$l.cache).list;
-# say $adts.perl;
-# say $adts.perl ;
-
-say "(* This is an auto-generated file. Do not edit. *)";
-
-say "";
-for $statements -> $statement {
- say "$statement"
-}
-say "open Adt_generator.Common;;";
-say "open $moduleName;;";
-
-say "";
-say "(* must be provided by one of the open or include statements: *)";
-for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly
-{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a, _) monad) -> state -> a $poly -> (state * new_a $poly , _) monad = fold_map__$poly;;"; }
-
-say "";
-for $adts.kv -> $index, $t {
- my $typeOrAnd = $index == 0 ?? "type" !! "and";
- say "$typeOrAnd $t =";
- if ($t eq $variant) {
- for $t.list -> $c {
- given $c {
- when '' { say " | $c" }
- default { say " | $c of $c" }
- }
- }
- say "";
- } elsif ($t eq $record) {
- say ' {';
- for $t.list -> $f
- { say " $f : $f ;"; }
- say ' }';
- } else {
- print " ";
- for $t.list -> $a
- { print "$a "; }
- print "$t";
- say "";
- }
-}
-say ";;";
-
-say "";
-for $adts.list -> $t {
- say "type ('state, 'err) _continue_fold_map__$t = \{";
- say " node__$t : 'state -> $t -> ('state * $t , 'err) monad ;";
- for $t.list -> $c
- { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'} , 'err) monad ;" }
- say ' };;';
-}
-
-say "type ('state , 'err) _continue_fold_map__$moduleName = \{";
-for $adts.list -> $t {
- say " $t : ('state , 'err) _continue_fold_map__$t ;";
-}
-say ' };;';
-
-say "";
-for $adts.list -> $t
-{ say "type ('state, 'err) fold_map_config__$t = \{";
- say " node__$t : 'state -> $t -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
- say " node__$t__pre_state : 'state -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
- say " node__$t__post_state : 'state -> $t -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
- for $t.list -> $c
- { say " $t__$c : 'state -> {$c || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
- }
- say '};;' }
-
-say "type ('state, 'err) fold_map_config__$moduleName =";
-say ' {';
-for $adts.list -> $t
-{ say " $t : ('state, 'err) fold_map_config__$t;" }
-say ' };;';
-
-say "include Adt_generator.Generic.BlahBluh";
-say "type ('state , 'adt_info_node_instance_info) _fold_config =";
-say ' {';
-say " generic : 'state -> 'adt_info_node_instance_info -> 'state;";
-# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
-for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin
-{ say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; }
-# look for built-in polymorphic types
-for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly
-{ say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
-say ' };;';
-say "module Arg = struct";
-say " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;";
-say "end;;";
-say "module Adt_info = Adt_generator.Generic.Adt_info (Arg);;";
-say "include Adt_info;;";
-say "type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;";
-
-say "";
-say 'type blahblah = {';
-for $adts.list -> $t
-{ say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;";
- for $t.list -> $c
- { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } }
-say '};;';
-
-# generic programming info about the nodes and fields
-say "";
-for $adts.list -> $t
-{ for $t.list -> $c
- { say "(* info for field or ctor $t.$c *)";
- say "let info__$t__$c : Adt_info.ctor_or_field = \{";
- say " name = \"$c\";";
- say " is_builtin = {$c ?? 'true' !! 'false'};";
- say " type_ = \"$c\";";
- say '}';
- say "";
- say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
- say " cf = info__$t__$c;";
- say " cf_continue = (fun state -> blahblah.fold__$t__$c blahblah visitor state x);";
- say " cf_new_fold = (fun visitor state -> blahblah.fold__$t__$c blahblah visitor state x);";
- say '};;';
- say ""; }
- say "(* info for node $t *)";
- say "let info__$t : Adt_info.node = \{";
- my $kind = do given $t {
- when $record { "Record" }
- when $variant { "Variant" }
- default { "Poly \"$_\"" }
- };
- say " kind = $kind;";
- say " declaration_name = \"$t\";";
- print " ctors_or_fields = [ ";
- for $t.list -> $c { print "info__$t__$c ; "; }
- say "];";
- say '};;';
- say "";
- # TODO: factor out some of the common bits here.
- say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->";
- say '{';
- say " instance_declaration_name = \"$t\";";
- do given $t {
- when $record {
- say ' instance_kind = RecordInstance {';
- print " fields = [ ";
- for $t.list -> $c { print "continue_info__$t__$c blahblah visitor x.$c ; "; }
- say " ];";
- say '};';
- }
- when $variant {
- say ' instance_kind = VariantInstance {';
- say " constructor = (match x with";
- for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c blahblah visitor { $c ?? 'v' !! '()' }"; }
- say " );";
- print " variant = [ ";
- for $t.list -> $c { print "info__$t__$c ; "; }
- say "];";
- say '};';
- }
- default {
- say ' instance_kind = PolyInstance {';
- say " poly = \"$_\";";
- print " arguments = [";
- # TODO: sort by c (currently we only have one-argument
- # polymorphic types so it happens to work but should be fixed.
- for $t.list -> $c { print "\"$c\""; }
- say "];";
- print " poly_continue = (fun state -> visitor.$_ visitor (";
- print $t
- .map(-> $c { "(fun state x -> (continue_info__$t__$c blahblah visitor x).cf_continue state)" })
- .join(", ");
- say ") state x);";
- say '};';
- }
- };
- say '};;';
- say ""; }
-
-say "";
-say "(* info for adt $moduleName *)";
-print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
-for $adts.list -> $t
-{ print "info__$t ; "; }
-say "];;";
-
-# fold functions
-say "";
-for $adts.list -> $t
-{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> qstate -> $t -> qstate = fun blahblah visitor state x ->";
- # TODO: add a non-generic continue_fold.
- say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
- say " adt = whole_adt_info () ;";
- say " node_instance = continue_info__$t blahblah visitor x";
- say ' } in';
- # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in";
- say " visitor.generic state node_instance_info;;";
- say "";
- for $t.list -> $c
- { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->";
- # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in";
- if ($c eq '') {
- # nothing to do, this constructor has no arguments.
- say " ignore blahblah; state;;";
- } elsif ($c) {
- say " ignore blahblah; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
- } else {
- say " blahblah.fold__$c blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
- }
- # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold";
- say ""; }
-}
-
-say "";
-say 'let blahblah : blahblah = {';
-for $adts.list -> $t
-{ say " fold__$t;";
- for $t.list -> $c
- { say " fold__$t__$c;" } }
-say '};;';
-
-# Tying the knot
-say "";
-for $adts.list -> $t
-{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x;;";
- for $t.list -> $c
- { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x;;" } }
-
-
-say "";
-say "type ('state, 'err) mk_continue_fold_map = \{";
-say " fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName";
-say '};;';
-
-
-# fold_map functions
-say "";
-for $adts.list -> $t
-{ say "let _fold_map__$t : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t, err) monad = fun mk_continue_fold_map visitor state x ->";
- say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
- say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*)
- say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*)
- say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*)
- say " return (state, new_x);;";
- say "";
- for $t.list -> $c
- { say "let _fold_map__$t__$c : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->";
- say " let continue_fold_map : (qstate,err) _continue_fold_map__$moduleName = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
- say " visitor.$t.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*)
- say ""; } }
-
-# make the "continue" object
-say "";
-say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
-say "let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{ fn = fun self visitor ->";
-say ' {';
-for $adts.list -> $t
-{ say " $t = \{";
- say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;";
- for $t.list -> $c
- { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; }
- say ' };' }
-say ' }';
-say '};;';
-say "";
-
-# fold_map functions : tying the knot
-say "";
-for $adts.list -> $t
-{ say "let fold_map__$t : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t,err) monad =";
- say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;";
- for $t.list -> $c
- { say "let fold_map__$t__$c : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' },err) monad =";
- say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } }
-
-
-for $adts.list -> $t
+# Auto-generated fold functions
+$*OUT = open $folder_filename, :w;
{
- say "let no_op_node__$t : type state . state -> $t -> (state,_) _continue_fold_map__$moduleName -> (state * $t,_) monad =";
- say " fun state v continue ->"; # (*_info*)
- say " match v with";
- if ($t eq $variant) {
- for $t.list -> $c
- { given $c {
- when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , $c)"; }
- default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , $c v)"; } } }
- } elsif ($t eq $record) {
- print ' { ';
- for $t.list -> $f
- { print "$f; "; }
- say "} ->";
- for $t.list -> $f
- { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; }
- print ' return (state , ({ ';
- for $t.list -> $f
- { print "$f; "; }
- say "\} : $t))";
- } else {
- print " v -> fold_map__$t ( ";
- print ( "continue.$t.$t__$_" for $t.list ).join(", ");
- say " ) state v;;";
- }
+ say "(* This is an auto-generated file. Do not edit. *)";
+ say "";
+ for $statements -> $statement { say "$statement" }
+ say "open $moduleName;;";
+
+ say "";
+ say " include Adt_generator.Generic.BlahBluh";
+ say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
+ say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;";
+ say " generic_empty_ctor : 'in_state -> 'out_state;";
+ # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+ for $adts.map({ $_