Merge

.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

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.
 
-
-
 <Syntax syntax="pascaligo">
 
 ```pascaligo group=records1
@@ -55,10 +53,8 @@ type user = {
 
 </Syntax>
 
-
 And here is how a record value is defined:
 
-
 <Syntax syntax="pascaligo">
 
 ```pascaligo group=records1
@@ -142,7 +138,7 @@ points on a plane.
 
 In PascaLIGO, the shape of that expression is
 `<record variable> with <record value>`.
-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
+update: a nameless new version of it has been created and returned by
-the blockless function.
+the block-less function.
 
 </Syntax>
 <Syntax syntax="cameligo">
@@ -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]]
+```
+
 <Syntax syntax="pascaligo">
 
 ### 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.
 
-
-
 <Syntax syntax="pascaligo">
 
 ```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
+Notice the optional value `Some (4,9)` instead of `(4,9)`. If we used
-use `None` instead, that would have meant that the binding is removed.
+`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 =>
 
 </Syntax>
 
-
 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
+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.
+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 `(<key>, <value>)`. Note also the semicolon
 separating individual map entries.  The annotated value `("<string>
 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 `(<key>, <value>)`. Note also the semicolon
 separating individual map entries.  The annotated value `("<string>
 value>" : address)` means that we cast a string into an address.

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";
         });

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
 
 

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 ;

src/bin/expect_tests/michelson_converter.ml

@@ -203,3 +203,120 @@ let%expect_test _ =
                { 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 } } } |}]

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});
+  ]

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

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

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

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; _} =
+and pp_ppar p = pp_par pp_pattern p
-  string "(" ^^ nest 1 (pp_pattern value.inside ^^ string ")")
 
 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; _} =
+and pp_par_expr e = pp_par pp_expr e
-  string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
 
 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; _} =
+and pp_type_app {value = ctor, tuple; _} =
-  let ctor, tuple = value in
   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; _} =
+and pp_type_par t = pp_par pp_type_expr t
-  string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")

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)

src/passes/1-parser/pascaligo/AST.ml

@@ -109,6 +109,7 @@ type eof = Region.t
 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
@@ -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
@@ -249,19 +250,14 @@ and param_var = {
 }
 
 and block = {
-  opening    : block_opening;
+  enclosing  : block_enclosing;
   statements : statements;
-  terminator : semi option;
+  terminator : semi option
-  closing    : block_closing
 }
 
-and block_opening =
+and block_enclosing =
-  Block of kwd_block * lbrace
+  Block    of kwd_block * lbrace * rbrace
-| Begin of kwd_begin
+| BeginEnd of kwd_begin * kwd_end
-
-and block_closing =
-  Block of rbrace
-| End   of 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;
+  cases     : ('a case_clause reg, vbar) nsepseq reg
-  closing   : closing
 }
 
 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
@@ -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

src/passes/1-parser/pascaligo/Parser.mly

@@ -122,7 +122,8 @@ attr_decl:
   open_attr_decl ";"? { $1 }
 
 open_attr_decl:
-  ne_injection("attributes","<string>") { $1 }
+  ne_injection("attributes","<string>") {
+    $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;
+                  terminator}
-                  closing = End $3}
     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;
+                 terminator}
-                 closing = RBracket $4}
    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;
+                   terminator}
-                   closing = End $3}
      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;
+                   terminator}
-                   closing = Block $4}
      in {region; value} }
 
 statement:
@@ -404,8 +404,7 @@ instruction:
 set_remove:
   "remove" expr "from" "set" path {
     let region = cover $1 (path_to_region $5) in
-    let value  = {
+    let value  = {kwd_remove = $1;
-      kwd_remove = $1;
                   element    = $2;
                   kwd_from   = $3;
                   kwd_set    = $4;
@@ -415,8 +414,7 @@ set_remove:
 map_remove:
   "remove" expr "from" "map" path {
     let region = cover $1 (path_to_region $5) in
-    let value  = {
+    let value  = {kwd_remove = $1;
-      kwd_remove = $1;
                   key        = $2;
                   kwd_from   = $3;
                   kwd_map    = $4;
@@ -425,82 +423,83 @@ map_remove:
 
 set_patch:
   "patch" path "with" ne_injection("set",expr) {
-    let region = cover $1 $4.region in
+    let set_inj = $4 (fun region -> NEInjSet region) in
-    let value  = {
+    let region = cover $1 set_inj.region in
-      kwd_patch = $1;
+    let value  = {kwd_patch = $1;
                   path      = $2;
                   kwd_with  = $3;
-      set_inj   = $4}
+                  set_inj}
     in {region; value} }
 
 map_patch:
   "patch" path "with" ne_injection("map",binding) {
-    let region = cover $1 $4.region in
+    let map_inj = $4 (fun region -> NEInjMap region) in
-    let value  = {
+    let region  = cover $1 map_inj.region in
-      kwd_patch = $1;
+    let value   = {kwd_patch = $1;
                    path      = $2;
                    kwd_with  = $3;
-      map_inj   = $4}
+                   map_inj}
     in {region; value} }
 
 injection(Kind,element):
   Kind sep_or_term_list(element,";") "end" {
+    fun mk_kwd ->
       let elements, terminator = $2 in
       let region = cover $1 $3
       and value  = {
-      opening  = Kwd $1;
+        kind      = mk_kwd $1;
+        enclosing = End $3;
         elements  = Some elements;
-      terminator;
+        terminator}
-      closing = End $3}
       in {region; value}
   }
 | Kind "end" {
+    fun mk_kwd ->
       let region = cover $1 $2
-    and value = {
+      and value  = {kind       = mk_kwd $1;
-      opening    = Kwd $1;
+                    enclosing  = End $2;
                     elements   = None;
-      terminator = None;
+                    terminator = None}
-      closing    = End $2}
       in {region; value}
   }
 | Kind "[" sep_or_term_list(element,";") "]" {
+    fun mk_kwd ->
       let elements, terminator = $3 in
       let region = cover $1 $4
-    and value = {
+      and value  = {kind      = mk_kwd $1;
-      opening  = KwdBracket ($1,$2);
+                    enclosing = Brackets ($2,$4);
                     elements  = Some elements;
-      terminator;
+                    terminator}
-      closing = RBracket $4}
       in {region; value}
   }
 | Kind "[" "]" {
+    fun mk_kwd ->
       let region = cover $1 $3
-    and value = {
+      and value  = {kind       = mk_kwd $1;
-      opening    = KwdBracket ($1,$2);
+                    enclosing  = Brackets ($2,$3);
                     elements   = None;
-      terminator = None;
+                    terminator = None}
-      closing    = RBracket $3}
       in {region; value} }
 
 ne_injection(Kind,element):
   Kind sep_or_term_list(element,";") "end" {
+    fun mk_kwd ->
       let ne_elements, terminator = $2 in
       let region = cover $1 $3
-    and value = {
+      and value  = {kind      = mk_kwd $1;
-      opening  = Kwd $1;
+                    enclosing = End $3;
                     ne_elements;
-      terminator;
+                    terminator}
-      closing = End $3}
       in {region; value}
   }
 | Kind "[" sep_or_term_list(element,";") "]" {
+    fun mk_kwd ->
       let ne_elements, terminator = $3 in
       let region = cover $1 $4
-    and value = {
+      and value = {kind      = mk_kwd $1;
-      opening  = KwdBracket ($1,$2);
+                   enclosing = Brackets ($2,$4);
                    ne_elements;
-      terminator;
+                   terminator}
-      closing = RBracket $4}
       in {region; value} }
 
 binding:
@@ -508,20 +507,19 @@ binding:
     let start  = expr_to_region $1
     and stop   = expr_to_region $3 in
     let region = cover start stop
-    and value  = {
+    and value  = {source = $1;
-      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 record_inj = $4 (fun region -> NEInjRecord region) in
-    let value  = {
+    let region = cover $1 record_inj.region in
-      kwd_patch  = $1;
+    let value  = {kwd_patch = $1;
                   path      = $2;
                   kwd_with  = $3;
-      record_inj = $4}
+                  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;
+    let value  = {lbrace=$1; inside=$2; rbrace=$3}
-                  inside = statements, terminator;
+    in ShortBlock {value; region} }
-                  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;
+                    cases     = $5 rhs_to_region}
-                    closing   = End $6}
       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;
+                    cases     = $6 rhs_to_region}
-                    closing   = RBracket $7}
       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 }
+  map_lookup {
-| injection("map",binding)     {    MapInj $1 }
+    MapLookUp $1
-| injection("big_map",binding) { BigMapInj $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;
+      terminator}
-      closing = End $3}
     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);
+      kind      = NEInjRecord $1;
+      enclosing = Brackets ($2,$4);
       ne_elements;
-     terminator;
+      terminator}
-     closing = RBracket $4}
     in {region; value} }
 
 update_record:
   path "with" ne_injection("record",field_path_assignment) {
-    let region = cover (path_to_region $1) $3.region in
+    let updates = $3 (fun region -> NEInjRecord region) in
-    let value  = {record=$1; kwd_with=$2; updates=$3}
+    let region = cover (path_to_region $1) updates.region in
+    let value  = {record=$1; kwd_with=$2; updates}
     in {region; value} }
 
 field_assignment:
@@ -1010,7 +1011,7 @@ arguments:
   par(nsepseq(expr,",")) { $1 }
 
 list_expr:
-  injection("list",expr) { EListComp $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 }

src/passes/1-parser/pascaligo/ParserLog.ml

@@ -27,7 +27,7 @@ let mk_state ~offsets ~mode ~buffer =
     val pad_node    = ""
     method pad_node = pad_node
 
-    (** The method [pad] updates the current padding, which is
+    (* 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
@@ -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 =
+and print_record_type state =
-  print_ne_injection state "record" print_field_decl record_type
+  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
+  let {enclosing; statements; terminator} = block.value in
-  print_block_opening state opening;
+  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_block_closing state closing
+      print_token state rbrace  "}"
-
+  | BeginEnd (kwd_begin, kwd_end) ->
-and print_block_opening state = function
+      print_token      state kwd_begin "begin";
-  Block (kwd_block, lbrace) ->
+      print_statements state statements;
-    print_token state kwd_block "block";
+      print_terminator state terminator;
-    print_token state lbrace    "{"
+      print_token      state kwd_end "end"
-| 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"
 
 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;
+  let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
-       lead_vbar; cases; closing} = node in
   print_token       state kwd_case "case";
   print_expr        state expr;
-  print_opening     state "of" opening;
+  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_closing     state closing
+      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;
+  let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
-       lead_vbar; cases; closing} = node in
   print_token      state kwd_case "case";
   print_expr       state expr;
-  print_opening    state "of" opening;
+  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_closing    state closing
+      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
+| MapInj inj           -> print_injection  state print_binding inj
-| BigMapInj inj        -> print_injection  state "big_map" 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 =
+and print_record_expr state =
-  print_ne_injection state "record" print_field_assign e
+  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.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
-  'a injection reg -> unit =
+  fun state print {value; _} ->
-  fun state kwd print {value; _} ->
+    let {kind; enclosing; elements; terminator} = value in
-    let {opening; elements; terminator; closing} = value in
+    print_injection_kwd state kind;
-    print_opening    state kwd opening;
+    match enclosing with
+      Brackets (lbracket, rbracket) ->
+        print_token      state lbracket "[";
         print_sepseq     state ";" print elements;
         print_terminator state terminator;
-    print_closing    state closing
+        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.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
-  'a ne_injection reg -> unit =
+  fun state print {value; _} ->
-  fun state kwd print {value; _} ->
+    let {kind; enclosing; ne_elements; terminator} = value in
-    let {opening; ne_elements; terminator; closing} = value in
+    print_ne_injection_kwd state kind;
-    print_opening    state kwd opening;
+    match enclosing with
+      Brackets (lbracket, rbracket) ->
+        print_token      state lbracket "[";
         print_nsepseq     state ";" print ne_elements;
         print_terminator state terminator;
-    print_closing    state closing
+        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
+and print_ne_injection_kwd state = function
-  Kwd kwd ->
+  NEInjAttr   kwd_attributes -> print_token state kwd_attributes "attributes"
-    print_token state kwd lexeme
+| NEInjSet    kwd_set        -> print_token state kwd_set "set"
-| KwdBracket (kwd, lbracket) ->
+| NEInjMap    kwd_map        -> print_token state kwd_map "map"
-    print_token state kwd lexeme;
+| NEInjRecord kwd_record     -> print_token state kwd_record "record"
-    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_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

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

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"

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)

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

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

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)
 

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
+  let aux  (pp,top_env) el =
-      (fun (pp,top_env) el ->
+    match Location.unwrap el with
-        let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in
+    | 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
+         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

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 =
+      return @@ E_variable (name)
-        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)
     )
   | 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
+          let%bind (input , output) = AST.get_t_function f.type_expression in
-          | E_lambda l -> lambda_to_iterator_body f l
+          let%bind f' = transpile_annotated_expression f in
-          | E_variable v -> (
+          let%bind input' = transpile_type input in
-              let%bind elt =
+          let%bind output' = transpile_type output in
-                trace_option (corner_case ~loc:__LOC__ "missing var") @@
+          let binder = Var.fresh ~name:"iterated" () in
-                AST.Environment.get_opt v f.environment in
+          let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in
-              match elt.definition with
+          ok ((binder , input'), application)
-              | 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
         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
+    match%bind transpile_declaration env cur with
-    ok (hds @ [ cur' ], env'.post_environment)
+    | 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

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 =

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

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 } ->
+let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf c ->
-  fprintf ppf "%a (reason: %s)" type_constraint_ c_simpl reason_simpl
+  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

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

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
+  )

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

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

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]

src/passes/8-typer-new/solver.ml

@@ -1,623 +1,24 @@
 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
-
+open Solver_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`
-    <polymorphic types are allowed. *)
-let check_applied ((reduced, _new_constraints) as x) =
-  let () = match reduced with
-      P_apply _ -> 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]
 
 (* 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 (<?) 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 Set.{ set = already_selected ; duplicates = _ ; added = selected_outputs } = Set.add_list selected_outputs already_selected in
-        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
@@ -626,8 +27,9 @@ let propagator_specialize1 : output_specialize1 propagator =
   | WasNotSelected ->
      (already_selected, [] , [])
 
-let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor
+(* TODO: put the heuristics with their state in a list. *)
-let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1
+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,40 +77,20 @@ 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 = {
+let initial_state : typer_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 *)
+        all_constraints          = ([] : type_constraint_simpl list) ;
-    aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare ; (* unionfind *)
+        aliases                  = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare;
-    assignments = Map.create ~cmp:Var.compare; (* c_constructor_simpl TypeVariableMap.t *)
+        assignments              = (Map.create ~cmp:Var.compare : (type_variable, c_constructor_simpl) Map.t);
-    grouped_by_variable = Map.create ~cmp:Var.compare; (* constraints TypeVariableMap.t *)
+        grouped_by_variable      = (Map.create ~cmp:Var.compare : (type_variable,         constraints) Map.t);
-    cycle_detection_toposort = (); (* unit *)
+        cycle_detection_toposort = ();
       } ;
     already_selected = {
-    break_ctor = Set.create ~cmp:compare_output_break_ctor;
+        break_ctor = Set.create ~cmp:Solver_should_be_generated.compare_output_break_ctor;
-    specialize1 = Set.create ~cmp:compare_output_specialize1 ;
+        specialize1 = Set.create ~cmp:Solver_should_be_generated.compare_output_specialize1 ;
       }
   }
 
@@ -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

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

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 }

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`
+    <polymorphic types are allowed. *)
+let check_applied ((reduced, _new_constraints) as x) =
+  let () = match reduced with
+      { tsrc = _ ; t = P_apply _ } -> failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *)
+    | _ -> ()
+  in x

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 = Wrap.lambda fresh input_type' output_type' result.type_expression in
-      let wrapped = Solver.Wrap.lambda fresh input_type' output_type' 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 =

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 k_type = T.{ tsrc = "wrap: map: k" ; t = P_variable (Core.fresh_type_variable ()) } in
-  let v_type = 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 k_type = T.{ tsrc = "wrap: big_map: k" ; t = P_variable (Core.fresh_type_variable ()) } in
-  let v_type = 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 ds' (p_constant C_map [ind' ; v]) "wrap: look_up: map" ;
-      c_equation (P_variable whole_expr) (p_constant C_option [P_variable v]) "wrap: look_up: whole" ;
+      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_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in
-  let unification_body = 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
+    | Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in
-  let body'  = match body with
+  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 unification_output result' "wrap: lambda: result" ;
-      c_equation (P_variable whole_expr)
+      c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ;
-                 (p_constant C_arrow ([P_variable unification_arg ;
+      c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr })
-                                       P_variable unification_body]))
+                 (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

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
+    ok (e', loc ed' d' :: acc)
-    | None -> ok (e', acc)
-    | Some d' -> 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
+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_name , type_expression) ->
+  | Declaration_type (type_binder , type_expr) ->
-      let%bind tv = evaluate_type env type_expression in
+      let%bind tv = evaluate_type env type_expr in
-      let env' = Environment.add_type (type_name) tv env in
+      let env' = Environment.add_type (type_binder) tv env in
-      ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
+      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

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

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,16 +303,19 @@ type contract_type = {
 }
 
 let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
-  let main_decl = List.rev @@ List.filter
+  let aux declt = match Location.unwrap declt with
-    (fun declt ->
+    | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
-      let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
+       if String.equal (Var.to_name binder) main_fname
-      String.equal (Var.to_name binder) main_fname
+       then Some p
-    )
+       else None
-    program
+    | Declaration_type _ -> None
   in
-  match main_decl with
+  let main_decl_opt = List.find_map aux @@ List.rev  program in
-  | (hd::_) -> (
+  let%bind main_decl =
-    let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
+    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
@@ -323,5 +331,3 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
     |  _ -> fail @@ Errors.bad_contract_io main_fname expr
   )
   | _ -> fail @@ Errors.bad_contract_io main_fname expr
-  )
-  | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")

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'
 

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

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_subarg   a b c = tc "arguments for (-)"        [a;b;c] [ (*TODO…*) ]
-    let tc_sizearg  a     = tc [a]     [ [int] ]
+    let tc_sizearg  a     = tc "arguments for size"       [a]     [ [int] ]
-    let tc_packable a     = tc [a]     [ [int] ; [string] ; [bool] (*TODO…*) ]
+    let tc_packable a     = tc "packable"                 [a]     [ [int] ; [string] ; [bool] (*TODO…*) ]
-    let tc_timargs  a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*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 [a;b;c] [ (*TODO…*) ]
+    let tc_edivargs a b c = tc "arguments for ediv"       [a;b;c] [ (*TODO…*) ]
-    let tc_divargs  a b c = tc [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 [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 [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 [a]     [ [nat] ; [int] ; [mutez] ; [timestamp] ]
+    let tc_comparable a   = tc "comparable"               [a]     [ [nat] ; [int] ; [mutez] ; [timestamp] ]
-    let tc_concatable a   = tc [a]     [ [string] ; [bytes] ]
+    let tc_concatable a   = tc "concatenable"             [a]     [ [string] ; [bytes] ]
-    let tc_storable a     = tc [a]     [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
+    let tc_storable a     = tc "storable"                 [a]     [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
 
     let t_none         = forall "a" @@ fun a -> option a
 

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

src/stages/1-ast_imperative/misc.ml

@@ -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@[<v>- %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 *)

src/stages/1-ast_imperative/misc.mli

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

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

src/stages/2-ast_sugar/misc.ml

@@ -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@[<v>- %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 *)

src/stages/2-ast_sugar/misc.mli

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

src/stages/4-ast_typed/.gitignore

@@ -1,2 +1,3 @@
 /generated_fold.ml
-
+/generated_map.ml
+/generated_o.ml

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 "@[<v>%a@]"

src/stages/4-ast_typed/PP_generic.ml

@@ -1,15 +1,19 @@
+open Types
 open Fold
 open Format
 open PP_helpers
 
+module M = struct
+  type no_state = NoState
   let needs_parens              = {
-    generic                   = (fun state info ->
+      generic                   = (fun NoState info ->
         match info.node_instance.instance_kind with
         | RecordInstance _ -> false
         | VariantInstance _ -> true
         | PolyInstance { poly =_; arguments=_; poly_continue } ->
-         (poly_continue state)
+           (poly_continue NoState)
       );
+      generic_empty_ctor        = (fun _ -> false) ;
       type_variable             = (fun _ _ _ -> true) ;
       bool                      = (fun _ _ _ -> false) ;
       int                       = (fun _ _ _ -> false) ;
@@ -35,82 +39,81 @@ let needs_parens              = {
       typeVariableMap           = (fun _ _ _ _ -> false) ;
     }
 
-let op ppf = {
+  let op ppf : (no_state, unit) fold_config = {
-    generic = (fun () info ->
+      generic = (fun NoState info ->
         match info.node_instance.instance_kind with
         | RecordInstance { fields } ->
-         let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) =
+           let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) =
-           fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in
+             fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in
            fprintf ppf "{@,@[<hv 2> %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields
         | VariantInstance { constructor ; _ } ->
-         if constructor.cf_new_fold needs_parens false
+           if constructor.cf_new_fold needs_parens NoState
-         then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) ()
+           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) ()
+                fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
         | PolyInstance { poly=_; arguments=_; poly_continue } ->
-         (poly_continue ())
+           (poly_continue NoState)
       );
-    int                       = (fun _visitor () i               -> fprintf ppf "%i" i );
+      generic_empty_ctor        = (fun NoState -> ()) ;
-    type_variable             = (fun _visitor () type_variable   -> fprintf ppf "Var %a" Var.pp type_variable) ;
+      int                       = (fun _visitor NoState i               -> fprintf ppf "%i" i );
-    bool                      = (fun _visitor () b               -> fprintf ppf "%s" (if b then "true" else "false")) ;
+      type_variable             = (fun _visitor NoState type_variable   -> fprintf ppf "Var %a" Var.pp type_variable) ;
-    z                         = (fun _visitor () i               -> fprintf ppf "%a" Z.pp_print i) ;
+      bool                      = (fun _visitor NoState b               -> fprintf ppf "%s" (if b then "true" else "false")) ;
-    string                    = (fun _visitor () str             -> fprintf ppf "\"%s\"" str) ;
+      z                         = (fun _visitor NoState i               -> fprintf ppf "%a" Z.pp_print i) ;
-    ligo_string               = (fun _visitor () str             -> fprintf ppf "%a" Ligo_string.pp str) ;
+      string                    = (fun _visitor NoState str             -> fprintf ppf "\"%s\"" str) ;
-    bytes                     = (fun _visitor () _bytes          -> fprintf ppf "bytes...") ;
+      ligo_string               = (fun _visitor NoState str             -> fprintf ppf "%a" Ligo_string.pp str) ;
-    unit                      = (fun _visitor () ()              -> fprintf ppf "()") ;
+      bytes                     = (fun _visitor NoState _bytes          -> fprintf ppf "bytes...") ;
-    packed_internal_operation = (fun _visitor () _op             -> fprintf ppf "Operation(...bytes)") ;
+      unit                      = (fun _visitor NoState ()              -> fprintf ppf "()") ;
-    expression_variable       = (fun _visitor () ev              -> fprintf ppf "%a" Var.pp ev) ;
+      packed_internal_operation = (fun _visitor NoState _op             -> fprintf ppf "Operation(...bytes)") ;
-    constructor'              = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ;
+      expression_variable       = (fun _visitor NoState ev              -> fprintf ppf "%a" Var.pp ev) ;
-    location                  = (fun _visitor () loc             -> fprintf ppf "%a" Location.pp loc) ;
+      constructor'              = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
-    label                     = (fun _visitor () (Label lbl)     -> fprintf ppf "Label %s" lbl) ;
+      location                  = (fun _visitor NoState loc             -> fprintf ppf "%a" Location.pp loc) ;
-    ast_core_type_expression  = (fun _visitor () te              -> fprintf ppf "%a" Ast_core.PP.type_expression te) ;
+      label                     = (fun _visitor NoState (Label lbl)     -> fprintf ppf "Label %s" lbl) ;
-    constructor_map           = (fun _visitor continue () cmap   ->
+      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 ()) v in
+          fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
         fprintf ppf "CMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
-    label_map                 = (fun _visitor continue () lmap   ->
+      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 ()) v in
+          fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in
         fprintf ppf "LMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst);
-    list                      = (fun _visitor continue () lst ->
+      list                      = (fun _visitor continue NoState lst ->
         let aux ppf elt =
-        fprintf ppf "%a" (fun _ppf -> continue ()) elt in
+          fprintf ppf "%a" (fun _ppf -> continue NoState) elt in
         fprintf ppf "[@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
-    location_wrap             = (fun _visitor continue () lwrap  ->
+      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 ()) wrap_content Location.pp location);
+        fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location);
-    (* list_ne = (fun _visitor continue () (first, lst) ->
+      option = (fun _visitor continue NoState o ->
-      let aux ppf elt =
-        fprintf ppf "%a" (fun _ppf -> continue ()) elt in
-      fprintf ppf "[@,@[<hv 2> %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) ;
+        | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ;
-    poly_unionfind            = (fun _visitor continue () p   ->
+      poly_unionfind            = (fun _visitor continue NoState p   ->
         let lst = (UnionFind.Poly2.partitions p) in
         let aux1 l = fprintf ppf "[@,@[<hv 2> (*%a*) %a @]@,]"
-                     (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p)
+                       (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p)
-                     (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in
+                       (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 [@,@[<hv 2> %a @]@,]" aux2 lst);
-    poly_set                  = (fun _visitor continue () set   ->
+      poly_set                  = (fun _visitor continue NoState set   ->
         let lst = (RedBlackTrees.PolySet.elements set) in
-      fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst);
+        fprintf ppf "Set [@,@[<hv 2> %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst);
-    typeVariableMap           = (fun _visitor continue () tvmap   ->
+      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 ()) v in
+          fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in
         fprintf ppf "typeVariableMap [@,@[<hv 2> %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst);
     }
 
-let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
+  let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v ->
-  fold (op 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)

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 ;
+}

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)

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

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_unit : expression
-val e_a_int : Z.t -> environment -> expression
+val e_a_int : Z.t -> expression
-val e_a_nat : Z.t -> environment -> expression
+val e_a_nat : Z.t -> expression
-val e_a_mutez : Z.t -> environment -> expression
+val e_a_mutez : Z.t -> expression
-val e_a_bool : bool -> environment -> expression
+val e_a_bool : bool -> expression
-val e_a_string : ligo_string -> environment -> expression
+val e_a_string : ligo_string -> expression
-val e_a_address : string -> environment -> expression
+val e_a_address : string -> expression
-val e_a_pair : expression -> expression -> environment -> expression
+val e_a_pair : expression -> expression -> expression
-val e_a_some : expression -> environment -> expression
+val e_a_some : expression -> expression
-val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression
+val e_a_lambda : lambda -> type_expression -> type_expression -> expression
-val e_a_none : type_expression -> environment -> expression
+val e_a_none : type_expression -> expression
-val e_a_record : expression label_map -> environment -> expression
+val e_a_record : expression label_map -> expression
-val e_a_application : expression -> expression -> environment -> expression
+val e_a_application : expression -> expression -> expression
-val e_a_variable : expression_variable -> type_expression -> environment -> expression
+val e_a_variable : expression_variable -> type_expression -> expression
-val ez_e_a_record : ( label * expression ) list -> environment -> expression
+val ez_e_a_record : ( label * expression ) list -> expression
-val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> 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

src/stages/4-ast_typed/combinators_environment.ml

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

src/stages/4-ast_typed/combinators_environment.mli

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

src/stages/4-ast_typed/comparable.ml

@@ -0,0 +1 @@
+include Compare_generic.Comparable

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

src/stages/4-ast_typed/compute_environment.ml

@@ -1,23 +1,9 @@
-open Ast_typed
+open Types
-
-(*
-  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.
-*)
 
 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
+    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 c.expr pre_env in
+      let post_env = Environment.add_ez_declaration c.binder expr pre_env in
-    let post_env' = merge c.post_env post_env in
+      let wrap_content = Declaration_constant { c with expr } 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)
+    )
+    | 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
+  let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
-  List.rev rev_decls
+  (last_env , List.rev rev_decls)

src/stages/4-ast_typed/dune

@@ -1,7 +1,7 @@
 (rule
-  (target generated_fold.ml)
+  (targets generated_fold.ml generated_map.ml generated_o.ml)
-  (deps ../adt_generator/generator.raku types.ml)
+  (deps ../adt_generator/generator.raku ast.ml)
-  (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.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))
 )

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

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
 

src/stages/4-ast_typed/fold.ml

@@ -1 +1,3 @@
 include Generated_fold
+include Generated_map
+include Generated_o

src/stages/4-ast_typed/misc.ml

@@ -512,27 +512,34 @@ 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
+      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) =
+let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = {
-  P_constant {
+  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

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

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 input_expr = e_a_variable binder input_type in
-    let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in
+    let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in
-    e_a_application main_expr input_expr env 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
+    expression_content b e.expression_content
-  and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec ->
+  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 =
+      if mem name b then ok empty else ok (singleton name)
-          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"
       )
     | 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

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
-
+include Ast
-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 ;
-}

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 =
+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 f state l ->
+  fun extra_info f state l ->
-  ignore (f, state, l) ; failwith "TODO
+  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 =
+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 f state s ->
+  fun extra_info 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 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

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

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

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,195 +60,66 @@ $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({ $_<name> eq $type }));
+       my $resolvedType = $type && $l.cache.first({ $_<name> eq $type });
+       my $isBuiltin = (! $type) || (! $resolvedType);
+       # my $isPoly = $resolvedType && $resolvedType<kind> ne $record && $resolvedType<kind> 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 ;
 
+# Auto-generated fold functions
+$*OUT = open $folder_filename, :w;
+{
     say "(* This is an auto-generated file. Do not edit. *)";
-
     say "";
-for $statements -> $statement {
+    for $statements -> $statement { say "$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({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).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<newName> =";
-  if ($t<kind> eq $variant) {
-      for $t<ctorsOrFields>.list -> $c {
-          given $c<type> {
-              when '' { say "  | $c<newName>" }
-              default { say "  | $c<newName> of $c<newType>" }
-          }
-      }
-      say "";
-  } elsif ($t<kind> eq $record) {
-      say '  {';
-      for $t<ctorsOrFields>.list -> $f
-      { say "    $f<newName> : $f<newType> ;"; }
-      say '  }';
-  } else {
-      print "  ";
-      for $t<ctorsOrFields>.list -> $a
-      { print "$a<newType> "; }
-      print "$t<kind>";
-      say "";
-  }
-}
-say ";;";
-
-say "";
-for $adts.list -> $t {
-    say "type ('state, 'err) _continue_fold_map__$t<name> = \{";
-        say "    node__$t<name> : 'state -> $t<name> -> ('state * $t<newName> , 'err) monad ;";
-    for $t<ctorsOrFields>.list -> $c
-    { say "    $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'} , 'err) monad ;" }
-    say '  };;';
-}
-
-say "type ('state , 'err) _continue_fold_map__$moduleName = \{";
-for $adts.list -> $t {
-    say "    $t<name> : ('state , 'err) _continue_fold_map__$t<name> ;";
-}
-say '  };;';
-
-say "";
-for $adts.list -> $t
-{ say "type ('state, 'err) fold_map_config__$t<name> = \{";
-  say "    node__$t<name> : 'state -> $t<name> -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t<newName> , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
-  say "    node__$t<name>__pre_state : 'state -> $t<name> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
-  say "    node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
-  for $t<ctorsOrFields>.list -> $c
-  { say "    $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c<newType> || '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<name> : ('state, 'err) fold_map_config__$t<name>;" }
-say '  };;';
-
     say "  include Adt_generator.Generic.BlahBluh";
-say "type ('state , 'adt_info_node_instance_info) _fold_config =";
+    say "  type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{";
-say '  {';
+    say "      generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;";
-say "    generic : 'state -> 'adt_info_node_instance_info -> '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({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
-{ say "    $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; }
+    { say "      $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_state;"; }
     # look for built-in polymorphic types
     for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
-{ say "    $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
+    { say "      $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_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 = {';
+    say "  module Adt_info = Adt_generator.Generic.Adt_info (struct";
+    say "    type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config;;";
+    say "  end);;";
+    say "  include Adt_info;;";
+    say "  type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_state) Adt_info.node_instance_info) _fold_config;;";
+
+    say "";
+    say '  type the_folds = {';
     for $adts.list -> $t
-{ say "  fold__$t<name> : 'state . blahblah -> 'state fold_config -> 'state -> $t<name> -> 'state;";
+    { say "      fold__$t<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> $t<name> -> 'out_state;";
       for $t<ctorsOrFields>.list -> $c
-  { say "  fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
+      { say "      fold__$t<name>__$c<name> : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> { $c<type> || 'unit' } -> 'out_state;"; } }
     say '    };;';
 
     # generic programming info about the nodes and fields
@@ -250,14 +131,15 @@ for $adts.list -> $t
         say "      name = \"$c<name>\";";
         say "      is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
         say "      type_ = \"$c<type>\";";
-    say '}';
-    say "";
-    say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
-    say "  cf = info__$t<name>__$c<name>;";
-    say "  cf_continue = (fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
-    say "  cf_new_fold = (fun visitor state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x);";
         say '    };;';
-    say ""; }
+        # say "";
+        say "  let continue_info__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c<type> || 'unit'} -> (in_qstate, out_qstate) Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{";
+        say "        cf = info__$t<name>__$c<name>;";
+        say "        cf_continue = (fun state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
+        say "        cf_new_fold = (fun visitor state -> the_folds.fold__$t<name>__$c<name> the_folds visitor state x);";
+        say '      };;';
+        # say "";
+      }
       say "  (* info for node $t<name> *)";
       say "  let info__$t<name> : Adt_info.node = \{";
       my $kind = do given $t<kind> {
@@ -271,23 +153,25 @@ for $adts.list -> $t
       for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
       say "];";
       say '    };;';
-  say "";
+      # say "";
       # TODO: factor out some of the common bits here.
-  say "let continue_info__$t<name> : type qstate . blahblah -> qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun blahblah visitor x ->";
+      say "  let continue_info__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> $t<name> -> (in_qstate , out_qstate) Adt_info.instance = fun the_folds visitor x ->";
       say '    {';
       say "      instance_declaration_name = \"$t<name>\";";
       do given $t<kind> {
           when $record {
               say '      instance_kind = RecordInstance {';
               print "      fields = [ ";
-        for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> blahblah visitor x.$c<name> ; "; }
+              for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> the_folds visitor x.$c<name> ; "; }
               say "      ];";
               say '  };';
           }
           when $variant {
-        say '  instance_kind = VariantInstance {';
+              say "      instance_kind =";
-        say "    constructor = (match x with";
+              say '        VariantInstance {';
-        for $t<ctorsOrFields>.list -> $c { say "    | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> blahblah visitor { $c<type> ?? 'v' !! '()' }"; }
+              say "            constructor =";
+              say "              (match x with";
+              for $t<ctorsOrFields>.list -> $c { say "               | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> the_folds visitor { $c<type> ?? 'v' !! '()' }"; }
               say "              );";
               print "            variant = [ ";
               for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
@@ -295,7 +179,8 @@ for $adts.list -> $t
               say '          };';
           }
           default {
-        say '  instance_kind = PolyInstance {';
+              say "      instance_kind =";
+              say '        PolyInstance {';
               say "            poly = \"$_\";";
               print "            arguments = [";
               # TODO: sort by c<name> (currently we only have one-argument
@@ -304,14 +189,15 @@ for $adts.list -> $t
               say "];";
               print "            poly_continue = (fun state -> visitor.$_ visitor (";
               print $t<ctorsOrFields>
-            .map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> blahblah visitor x).cf_continue state)" })
+                  .map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> the_folds visitor x).cf_continue state)" })
                   .join(", ");
               say ") state x);";
               say '          };';
           }
       };
       say '    };;';
-  say ""; }
+      # say "";
+    }
 
     say "";
     say "  (* info for adt $moduleName *)";
@@ -323,32 +209,37 @@ say "];;";
     # fold functions
     say "";
     for $adts.list -> $t
-{ say "let fold__$t<name> : type qstate . blahblah -> qstate fold_config -> qstate -> $t<name> -> qstate = fun blahblah visitor state x ->";
+    { say "  let fold__$t<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_qstate = fun the_folds visitor state x ->";
       # TODO: add a non-generic continue_fold.
-  say '  let node_instance_info : qstate Adt_info.node_instance_info = {';
+      say '    let node_instance_info : (in_qstate , out_qstate) Adt_info.node_instance_info = {';
       say "        adt = whole_adt_info () ;";
-  say "    node_instance = continue_info__$t<name> blahblah visitor x";
+      say "        node_instance = continue_info__$t<name> the_folds visitor x";
       say '      } in';
       # say "  let (state, new_x) = visitor.$t<name>.node__$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
       say "    visitor.generic state node_instance_info;;";
-  say "";
+      # say "";
       for $t<ctorsOrFields>.list -> $c
-  { say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun blahblah { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
+      { say "  let fold__$t<name>__$c<name> : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_qstate = fun the_folds visitor state { $c<type> ?? 'x' !! '()' } ->";
-    # say "  let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
+        # say "  let ctor_or_field_instance_info : (in_qstate , out_qstate) Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
         if ($c<type> eq '') {
             # nothing to do, this constructor has no arguments.
-        say "  ignore blahblah; state;;";
+            say "    ignore the_folds; visitor.generic_empty_ctor state;;";
         } elsif ($c<isBuiltin>) {
-        say "  ignore blahblah; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) 
+            say "    ignore the_folds; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
         } else {
-        say "  blahblah.fold__$c<type> blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
+            say "    the_folds.fold__$c<type> the_folds visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
         }
         # say "  visitor.$t<name>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
-    say ""; }
+        # say "";
       }
+    }
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
+      { say "  let fold__$builtin : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun the_folds visitor state x ->";
+        say "    ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
 
     say "";
-say 'let blahblah : blahblah = {';
+    say '  let the_folds : the_folds = {';
     for $adts.list -> $t
     { say "    fold__$t<name>;";
       for $t<ctorsOrFields>.list -> $c
@@ -358,10 +249,103 @@ say '};;';
     # Tying the knot
     say "";
     for $adts.list -> $t
-{ say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah visitor state x;;";
+    { say "  let fold__$t<name> : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $t<name> -> out_qstate = fun visitor state x -> fold__$t<name> the_folds visitor state x;;";
       for $t<ctorsOrFields>.list -> $c
-  { say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> blahblah visitor state x;;" } }
+      { say "  let fold__$t<name>__$c<name> : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> { $c<type> || 'unit' } -> out_qstate = fun visitor state x -> fold__$t<name>__$c<name> the_folds visitor state x;;" } }
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
+    { say "  let fold__$builtin : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; }
 
+    say "";
+    say "  module Folds (M : sig type in_state type out_state type 'a t val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_state) -> 'a t end) = struct";
+    for $adts.list -> $t
+    { say "  let $t<name> = M.f fold__$t<name>;;"; }
+    # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
+    for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
+    { say "  let $builtin = M.f fold__$builtin"; }
+    say "  end";
+}
+
+# auto-generated fold_map functions
+$*OUT = open $mapper_filename, :w;
+{
+    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 "module type OSig = sig";
+    for $adts.list -> $t {
+        say "  type $t<newName>;;";
+    }
+
+    for $adts.list -> $t {
+        if ($t<kind> eq $variant) {
+            for $t<ctorsOrFields>.list -> $c {
+                say "  val make__$t<newName>__$c<newName> : {$c<type> ne '' ?? "$c<newType> " !! 'unit'} -> $t<newName>;;";
+            }
+        } elsif ($t<kind> eq $record) {
+            print "  val make__$t<newName>";
+            say ' :';
+            for $t<ctorsOrFields>.list -> $f
+            { say "    {$f<newName>}:{$f<newType>} ->"; }
+            say "    $t<newName>;;";
+        } else {
+            print "  val make__$t<newName> : (";
+            print $t<ctorsOrFields>.map({$_<newType>}).join(" , ");
+            say ") $t<kind> -> $t<newName>;;";
+        }
+    }
+
+    say "";
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
+    { my $ty = $t<ctorsOrFields>[0]<type>;
+      my $typeclass = $typeclasses{$t<kind>};
+      say "  val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; }
+    say "end";
+
+    say "";
+    say "module Mapper (* O : OSig  Functors are too slow and consume a lot of memory when compiling large files with OCaml. We're hardcoding the O module below for now. *) = struct";
+    say "  module O : OSig = $oModuleName";
+    say "";
+    say "  (* must be provided by one of the open or include statements: *)";
+    say "  module CheckInputSignature = struct";
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
+    { say "    let fold_map__$poly : type a new_a state err .{ $typeclasses{$poly} ?? " new_a extra_info__{$typeclasses{$poly}} ->" !! "" } (state -> a -> (state * new_a, err) monad) -> state -> a $poly -> (state * new_a $poly , err) monad = fold_map__$poly;;"; }
+    say "  end";
+
+    say "";
+    for $adts.list -> $t {
+        say "  type ('state, 'err) _continue_fold_map__$t<name> = \{";
+        say "      node__$t<name> : 'state -> $t<name> -> ('state * $t<oNewName> , 'err) monad ;";
+        for $t<ctorsOrFields>.list -> $c
+        { say "      $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<oNewType> || 'unit'} , 'err) monad ;" }
+        say '    };;';
+    }
+
+    say "  type ('state , 'err) _continue_fold_map__$moduleName = \{";
+    for $adts.list -> $t {
+        say "      $t<name> : ('state , 'err) _continue_fold_map__$t<name> ;";
+    }
+    say '    };;';
+
+    say "";
+    for $adts.list -> $t
+    { say "  type ('state, 'err) fold_map_config__$t<name> = \{";
+      say "      node__$t<name> : 'state -> $t<name> -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t<oNewName> , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
+      say "      node__$t<name>__pre_state : 'state -> $t<name> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
+      say "      node__$t<name>__post_state : 'state -> $t<name> -> $t<oNewName> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
+      for $t<ctorsOrFields>.list -> $c
+      { say "      $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c<oNewType> || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
+      }
+      say '  };;' }
+
+    say "  type ('state, 'err) fold_map_config__$moduleName = \{";
+    for $adts.list -> $t
+    { say "      $t<name> : ('state, 'err) fold_map_config__$t<name>;" }
+    say '    };;';
 
     say "";
     say "  type ('state, 'err) mk_continue_fold_map = \{";
@@ -372,23 +356,27 @@ say '};;';
     # fold_map functions
     say "";
     for $adts.list -> $t
-{ say "let _fold_map__$t<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<newName>, err) monad = fun mk_continue_fold_map visitor state x ->";
+    { say "  let _fold_map__$t<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<oNewName>, 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<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
       say "    visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
       say "    visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
       say "    return (state, new_x);;";
-  say "";
+      # say "";
       for $t<ctorsOrFields>.list -> $c
-  { say "let _fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->";
+      { say "  let _fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<oNewType> || '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<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
-    say ""; } }
+        # 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 "  let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{";
+    say "      fn =";
+    say "        fun self visitor ->";
     say '        {';
     for $adts.list -> $t
     { say "          $t<name> = \{";
@@ -403,23 +391,23 @@ say "";
     # fold_map functions : tying the knot
     say "";
     for $adts.list -> $t
-{ say "let fold_map__$t<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<newName>,err) monad =";
+    { say "  let fold_map__$t<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t<name> -> (qstate * $t<oNewName>,err) monad =";
       say "    fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
       for $t<ctorsOrFields>.list -> $c
-  { say "let fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' },err) monad =";
+      { say "  let fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<oNewType> || 'unit' },err) monad =";
         say "    fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x;;"; } }
 
-
+    say "";
     for $adts.list -> $t
     {
-   say "let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) _continue_fold_map__$moduleName -> (state * $t<newName>,_) monad =";
+        say "  let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) _continue_fold_map__$moduleName -> (state * $t<oNewName>,_) monad =";
         say "    fun state v continue ->"; # (*_info*)
         say "      match v with";
         if ($t<kind> eq $variant) {
             for $t<ctorsOrFields>.list -> $c
             { given $c<type> {
-        when '' { say "    | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , $c<newName>)"; }
+                when '' { say "      | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , O.make__$t<newName>__$c<newName> ())"; }
-        default { say "    | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } }
+                default { say "      | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , O.make__$t<newName>__$c<newName> v)"; } } }
         } elsif ($t<kind> eq $record) {
             print '        { ';
             for $t<ctorsOrFields>.list -> $f
@@ -427,14 +415,20 @@ for $adts.list -> $t
             say "} ->";
             for $t<ctorsOrFields>.list -> $f
             { say "        continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
-    print '      return (state , ({ ';
+            print "        return (state , (O.make__$t<newName>";
             for $t<ctorsOrFields>.list -> $f
-    { print "$f<newName>; "; }
+            { print " ~$f<newName>"; }
-    say "\} : $t<newName>))";
+            say " : $t<oNewName>))";
         } else {
-    print "      v -> fold_map__$t<kind> ( ";
+            print "        v -> (fold_map__$t<kind>";
+            if ($t<kind> ne $record && $t<kind> ne $variant && $typeclasses{$t<kind>}) {
+                for  $t<ctorsOrFields>.list -> $a
+                { print " O.extra_info__$a<type>__{$typeclasses{$t<kind>}}"; }
+            }
+            print " ( ";
             print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
-    say " ) state v;;";
+            say " ) state v)";
+            say "        >>? fun (state, x) -> return (state, O.make__$t<name> x);;";
         }
     }
 
@@ -465,9 +459,53 @@ for $adts.list -> $t
       say "  let with__$t<name>__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
       for $t<ctorsOrFields>.list -> $c
       { say "  let with__$t<name>__$c<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }
+    say "end";
+}
+
+$*OUT = open $combinators_filename, :w;
+{
+    say "(* This is an auto-generated file. Do not edit. *)";
+    say "";
+    for $statements -> $statement { say "$statement" }
+    say "open $moduleName;;";
+    say "";
+    for $adts.list -> $t {
+        say "type nonrec $t<name> = $t<name>;;";
+    }
+
+    for $adts.list -> $t {
+        if ($t<kind> eq $variant) {
+            for $t<ctorsOrFields>.list -> $c {
+                say "let make__$t<name>__$c<name> : {$c<type> ne '' ?? "$c<newType> " !! 'unit'} -> $t<name> = fun {$c<type> ne '' ?? 'v' !! '()'} -> $c<name> {$c<type> ne '' ?? 'v ' !! ''};;";
+            }
+        } elsif ($t<kind> eq $record) {
+            print "let make__$t<name>";
+            print ' :';
+            for $t<ctorsOrFields>.list -> $f
+            { print "  {$f<newName>}:{$f<newType>} ->"; }
+            print "  $t<newName> = fun";
+            for $t<ctorsOrFields>.list -> $f
+            { print "  ~{$f<newName>}"; }
+            print " -> \{";
+            for $t<ctorsOrFields>.list -> $f
+            { print " {$f<newName>} ;"; }
+            say " \};;";
+        } else {
+            print "let make__$t<newName> : (";
+            print $t<ctorsOrFields>.map({$_<newType>}).join(" , ");
+            print ") $t<kind> -> $t<newName> = ";
+            print "fun x -> x";
+            say ";;";
+        }
+    }
 
     say "";
-say "module Folds (M : sig type state type 'a t val f : (state fold_config -> state -> 'a -> state) -> 'a t  end) = struct";
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
-for $adts.list -> $t
+    { my $ty = $t<ctorsOrFields>[0]<type>;
-{ say "let $t<name> = M.f fold__$t<name>;;"; }
+      my $typeclass = $typeclasses{$t<kind>};
-say "end";
+      say "let extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass = {tc $typeclass}.$ty;;";
+    }
+    # Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare:
+    say "(* Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare: *)";
+    say "module DummyTest_ = Generated_fold;;";
+}

src/stages/adt_generator/generic.ml

@@ -10,35 +10,35 @@ type 'state generic_continue_fold_node = {
   type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;
 end
 
-module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct
+module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct
   type kind =
   | Record
   | Variant
   | Poly of string
 
-  type 'state record_instance = {
+  type ('in_state , 'out_state) record_instance = {
-    fields : 'state ctor_or_field_instance list;
+    fields : ('in_state , 'out_state) ctor_or_field_instance list;
   }
 
-  and 'state constructor_instance = {
+  and ('in_state , 'out_state) constructor_instance = {
-    constructor : 'state ctor_or_field_instance ;
+    constructor : ('in_state , 'out_state) ctor_or_field_instance ;
     variant : ctor_or_field list
   }
 
-  and 'state poly_instance = {
+  and ('in_state , 'out_state) poly_instance = {
     poly : string;
     arguments : string list;
-    poly_continue : 'state -> 'state
+    poly_continue : 'in_state -> 'out_state
   }
 
-  and 'state kind_instance =
+  and ('in_state , 'out_state) kind_instance =
-  | RecordInstance of 'state record_instance
+  | RecordInstance of ('in_state , 'out_state) record_instance
-  | VariantInstance of 'state constructor_instance
+  | VariantInstance of ('in_state , 'out_state) constructor_instance
-  | PolyInstance of 'state poly_instance
+  | PolyInstance of ('in_state , 'out_state) poly_instance
 
-  and 'state instance = {
+  and ('in_state , 'out_state) instance = {
     instance_declaration_name : string;
-    instance_kind : 'state kind_instance;
+    instance_kind : ('in_state , 'out_state) kind_instance;
   }
 
   and ctor_or_field =
@@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
       type_ : string;
     }
 
-  and 'state ctor_or_field_instance =
+  and ('in_state , 'out_state) ctor_or_field_instance =
     {
       cf : ctor_or_field;
-      cf_continue : 'state -> 'state;
+      cf_continue : 'in_state -> 'out_state;
-      cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state;
+      cf_new_fold : 'in_state 'out_state . ('in_state , 'out_state , (('in_state , 'out_state) node_instance_info)) M.fold_config -> 'in_state -> 'out_state;
     }
 
   and node =
@@ -64,9 +64,9 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi
 
   (* TODO: rename things a bit in this file. *)
   and adt = node list
-  and 'state node_instance_info = {
+  and ('in_state , 'out_state) node_instance_info = {
     adt           : adt ;
-    node_instance : 'state instance ;
+    node_instance : ('in_state , 'out_state) instance ;
   }
-  and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance
+  and ('in_state , 'out_state) ctor_or_field_instance_info = adt * node * ('in_state , 'out_state) ctor_or_field_instance
 end

src/stages/typesystem/misc.ml

@@ -29,7 +29,6 @@ module Substitution = struct
           ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env
     and s_type_environment : T.type_environment w = fun ~substs tenv ->
       bind_map_list (fun T.{type_variable ; type_} ->
-        let%bind type_variable = s_type_variable ~substs type_variable in
         let%bind type_ = s_type_expression ~substs type_ in
         ok @@ T.{type_variable ; type_}) tenv
     and s_environment : T.environment w = fun ~substs T.{expression_environment ; type_environment} ->
@@ -45,14 +44,6 @@ module Substitution = struct
       let () = ignore @@ substs in
       ok var
 
-    and s_type_variable : T.type_variable w = fun ~substs tvar ->
-      let _TODO = ignore @@ substs in
-      Printf.printf "TODO: subst: unimplemented case s_type_variable";
-      ok @@ tvar
-      (* if String.equal tvar v then
-       *   expr
-       * else
-       *   ok tvar *)
     and s_label : T.label w = fun ~substs l ->
       let () = ignore @@ substs in
       ok l
@@ -71,7 +62,12 @@ module Substitution = struct
       ok @@ type_name
 
     and s_type_content : T.type_content w = fun ~substs -> function
-        | T.T_sum _ -> failwith "TODO: T_sum"
+        | T.T_sum s ->
+           let aux T.{ ctor_type; michelson_annotation ; ctor_decl_pos } =
+             let%bind ctor_type = s_type_expression ~substs ctor_type in
+             ok @@ T.{ ctor_type; michelson_annotation; ctor_decl_pos } in
+           let%bind s = Ast_typed.Helpers.bind_map_cmap aux s in
+           ok @@ T.T_sum s
         | T.T_record _ -> failwith "TODO: T_record"
         | T.T_constant type_name ->
           let%bind type_name = s_type_name_constant ~substs type_name in
@@ -195,20 +191,19 @@ module Substitution = struct
         let%bind cases = s_matching_expr ~substs cases in
         ok @@ T.E_matching {matchee;cases}
 
-    and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } ->
+    and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; location } ->
       let%bind expression_content = s_expression_content ~substs expression_content in
       let%bind type_expr = s_type_expression ~substs type_expression in
-      let%bind environment = s_environment ~substs environment in
       let location = location in
-      ok T.{ expression_content;type_expression=type_expr; environment; location }
+      ok T.{ expression_content;type_expression=type_expr; location }
 
     and s_declaration : T.declaration w = fun ~substs ->
       function
-        Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} ->
+      | Ast_typed.Declaration_constant {binder ; expr ; inline} ->
          let%bind binder = s_variable ~substs binder in
          let%bind expr = s_expression ~substs expr in
-        let%bind post_env = s_environment ~substs post_env in
+         ok @@ Ast_typed.Declaration_constant {binder; expr; inline}
-        ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env}
+      | Declaration_type t -> ok (Ast_typed.Declaration_type t)
 
     and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
       Trace.bind_map_location (s_declaration ~substs) d    
@@ -224,24 +219,24 @@ module Substitution = struct
     and type_value ~tv ~substs =
       let self tv = type_value ~tv ~substs in
       let (v, expr) = substs in
-      match (tv : type_value) with
+      match (tv : type_value).t with
       | P_variable v' when Var.equal v' v -> expr
       | P_variable _ -> tv
       | P_constant {p_ctor_tag=x ; p_ctor_args=lst} -> (
           let lst' = List.map self lst in
-          P_constant {p_ctor_tag=x ; p_ctor_args=lst'}
+          { tsrc = "?TODO1?" ; t = P_constant {p_ctor_tag=x ; p_ctor_args=lst'} }
         )
       | P_apply { tf; targ } -> (
-          P_apply { tf = self tf ; targ = self targ }
+          { tsrc = "?TODO2?" ; t = P_apply { tf = self tf ; targ = self targ } }
         )
       | P_forall p -> (
           let aux c = constraint_ ~c ~substs in
           let constraints = List.map aux p.constraints in
           if (p.binder = v) then (
-            P_forall { p with constraints }
+            { tsrc = "?TODO3?" ; t = P_forall { p with constraints } }
           ) else (
             let body = self p.body in
-            P_forall { p with constraints ; body }
+            { tsrc = "?TODO4?" ; t = P_forall { p with constraints ; body } }
           )
         )
 
@@ -271,9 +266,10 @@ module Substitution = struct
 
     (* Performs beta-reduction at the root of the type *)
     let eval_beta_root ~(tv : type_value) =
-      match tv with
+      match tv.t with
-        P_apply {tf = P_forall { binder; constraints; body }; targ} ->
+        P_apply {tf = { tsrc = _ ; t = P_forall { binder; constraints; body } }; targ} ->
         let constraints = List.map (fun c -> constraint_ ~c ~substs:(mk_substs ~v:binder ~expr:targ)) constraints in
+        (* TODO: indicate in the result's tsrc that it was obtained via beta-reduction of the original type *)
         (type_value ~tv:body ~substs:(mk_substs ~v:binder ~expr:targ) , constraints)
       | _ -> (tv , [])
   end

src/stages/typesystem/shorthands.ml

@@ -2,19 +2,24 @@ open Ast_typed.Types
 open Core
 open Ast_typed.Misc
 
-let tc type_vars allowed_list : type_constraint =
+let tc description type_vars allowed_list : type_constraint = {
-  { c = C_typeclass {tc_args = type_vars ; typeclass = allowed_list} ; reason = "shorthands: typeclass" }
+    c = C_typeclass {tc_args = type_vars ;typeclass = allowed_list} ;
+    reason = "typeclass for operator: " ^ description
+  }
 
 let forall binder f =
   let () = ignore binder in
   let freshvar = fresh_type_variable () in
-  P_forall { binder = freshvar ; constraints = [] ; body = f (P_variable freshvar) }
+  let body = f { tsrc = "shorthands.ml/forall" ; t = P_variable freshvar } in
+  { tsrc = "shorthands.ml/forall" ;
+    t = P_forall { binder = freshvar ; constraints = [] ; body } }
 
 let forall_tc binder f =
   let () = ignore binder in
   let freshvar = fresh_type_variable () in
-  let (tc, ty) = f (P_variable freshvar) in
+  let (tc, ty) = f { tsrc = "shorthands.ml/forall_tc" ; t = P_variable freshvar } in
-  P_forall { binder = freshvar ; constraints = tc ; body = ty }
+  { tsrc = "shorthands.ml/forall_tc" ;
+    t = P_forall { binder = freshvar ; constraints = tc ; body = ty } }
 
 (* chained forall *)
 let forall2 a b f =
@@ -55,7 +60,7 @@ let map  k v      = p_constant C_map       [k; v]
 let unit          = p_constant C_unit      []
 let list   t      = p_constant C_list      [t]
 let set    t      = p_constant C_set       [t]
-let bool          = P_variable Stage_common.Constant.t_bool
+let bool          = { tsrc = "built-in type" ; t = P_variable Stage_common.Constant.t_bool }
 let string        = p_constant C_string    []
 let nat           = p_constant C_nat       []
 let mutez         = p_constant C_mutez     []

src/test/adt_generator/.gitignore

@@ -1 +1,3 @@
 /generated_fold.ml
+/generated_map.ml
+/generated_o.ml

src/test/adt_generator/amodule.ml

@@ -1,3 +1,4 @@
+[@@@warning "-33"]
 (* open Amodule_utils *)
 
 type root =

src/test/adt_generator/dune

@@ -1,7 +1,7 @@
 (rule
-  (target generated_fold.ml)
+  (targets generated_fold.ml generated_map.ml generated_o.ml)
   (deps ../../../src/stages/adt_generator/generator.raku amodule.ml)
-  (action (with-stdout-to generated_fold.ml (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml)))
+  (action (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml))
   (mode (promote (until-clean) (only *)))
 )
 

src/test/adt_generator/fold.ml

@@ -1 +1,2 @@
 include Generated_fold
+include Generated_map.Mapper

src/test/adt_generator/use_a_fold.ml

@@ -2,6 +2,8 @@ open Amodule
 open Fold
 open Simple_utils.Trace
 
+module O = Fold.O
+
 let (|>) v f = f v
 
 module Errors = struct
@@ -22,9 +24,9 @@ let () =
   let op =
     no_op |>
       with__a (fun state the_a (*_info*) continue_fold ->
-          let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in
+          let%bind state, a1 = continue_fold.ta1.node__ta1 state the_a.a1 in
-          let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in
+          let%bind state, a2 = continue_fold.ta2.node__ta2 state the_a.a2 in
-          ok (state + 1, { a1__' ; a2__' }))
+          ok (state + 1, (O.make__a ~a1 ~a2 : O.a)))
   in
   let state = 0 in
   let%bind (state , _) = fold_map__root op state some_root in
@@ -61,35 +63,33 @@ let () =
 let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
 let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *)
 
+type no_state = NoState
 let () =
   let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in
-  let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in
+  let op : ('i, 'o) Generated_fold.fold_config = {
-  let nostate = false, "" in
+      generic = (fun NoState info ->
-  let op = {
-      generic = (fun state info ->
-        assert_nostate state;
         match info.node_instance.instance_kind with
         | RecordInstance { fields } ->
-           false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
+           false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }"
         | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } ->
-           (match cf_continue nostate with
+           (match cf_continue NoState with
             | true,  arg -> true, name ^ " (" ^ arg ^ ")"
             | false, arg -> true, name ^ " "  ^ arg)
         | PolyInstance { poly=_; arguments=_; poly_continue } ->
-           (poly_continue nostate)
+           (poly_continue NoState)
       ) ;
-      string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
+      generic_empty_ctor = (fun NoState -> false, "") ;
-      unit = (fun _visitor state () -> assert_nostate state; false , "()") ;
+      string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ;
-      int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
+      unit = (fun _visitor NoState () -> false , "()") ;
-      list = (fun _visitor continue state lst ->
+      int = (fun _visitor NoState i -> false , string_of_int i) ;
-        assert_nostate state;
+      list = (fun _visitor continue NoState lst ->
-        false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
+        false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ;
       (* generic_ctor_or_field = (fun _info state ->
        *   match _info () with
        *     (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
        * ); *)
     } in
-  let (_ , state) = fold__root op nostate some_root in
+  let (_ , state) = Generated_fold.fold__root op NoState some_root in
   let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
   if String.equal state expected; then
     ()

src/test/coase_tests.ml

@@ -13,13 +13,13 @@ let get_program =
     | Some s -> ok s
     | None -> (
         let%bind (program , state) = type_file "./contracts/coase.ligo" in
-        let () = Typer.Solver.discard_state state in
+        s := Some (program , state) ;
-        s := Some program ;
+        ok (program , state)
-        ok program
       )
 
 let compile_main () = 
-  let%bind typed_prg      = get_program () in
+  let%bind (typed_prg, state) = get_program () in
+  let () = Typer.Solver.discard_state state in
   let%bind mini_c_prg         = Ligo.Compile.Of_typed.compile typed_prg in
   let%bind michelson_prg      = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
   let%bind (_contract: Tezos_utils.Michelson.michelson) =

src/test/contracts/double_fold_converter.religo

@@ -0,0 +1,72 @@
+type tokenId = nat;
+type tokenOwner = address;
+type tokenAmount = nat;
+type transferContents = {
+    to_: tokenOwner,
+    token_id: tokenId,
+    amount: tokenAmount
+};
+type transfer = {
+    from_: tokenOwner,
+    txs: list(transferContents)
+};
+type transferContentsMichelson = michelson_pair_right_comb(transferContents);
+type transferAuxiliary = {
+    from_: tokenOwner,
+    txs: list(transferContentsMichelson)
+};
+type transferMichelson = michelson_pair_right_comb(transferAuxiliary);
+type transferParameter = list(transferMichelson);
+type parameter = 
+| Transfer(transferParameter)
+type storage = big_map(tokenId, tokenOwner);
+type entrypointParameter = (parameter, storage);
+type entrypointReturn = (list(operation), storage);
+let errorTokenUndefined = "TOKEN_UNDEFINED";
+let errorNotOwner = "NOT_OWNER";
+let errorInsufficientBalance = "INSUFFICIENT_BALANCE";
+type transferContentsIteratorAccumulator = (storage, tokenOwner);
+let transferContentsIterator = ((accumulator, transferContentsMichelson): (transferContentsIteratorAccumulator, transferContentsMichelson)): transferContentsIteratorAccumulator => {
+    let (storage, from_) = accumulator;
+    let transferContents: transferContents = Layout.convert_from_right_comb(transferContentsMichelson);
+    let tokenOwner: option(tokenOwner) = Map.find_opt(transferContents.token_id, storage);
+    let tokenOwner = switch (tokenOwner) {
+        | None => (failwith(errorTokenUndefined): tokenOwner)
+        | Some(tokenOwner) => if (tokenOwner == from_) {
+                tokenOwner
+            } else {
+                (failwith(errorInsufficientBalance): tokenOwner);
+            }
+    };
+    let storage = Map.update(
+        transferContents.token_id,
+        Some(transferContents.to_),
+        storage
+    );
+    (storage, from_)
+};
+let allowOnlyOwnTransfer = (from: tokenOwner): unit => {
+    if (from != Tezos.sender) {
+        failwith(errorNotOwner)
+    } else { (); }
+}
+let transferIterator = ((storage, transferMichelson): (storage, transferMichelson)): storage => {
+    let transferAuxiliary2: transferAuxiliary = Layout.convert_from_right_comb(transferMichelson);
+    let from_: tokenOwner = transferAuxiliary2.from_;
+    allowOnlyOwnTransfer(from_);
+    let (storage, _) = List.fold(
+        transferContentsIterator, 
+        transferAuxiliary2.txs,
+        (storage, from_)
+    );
+    storage
+};
+let transfer = ((transferParameter, storage): (transferParameter, storage)): entrypointReturn => {
+    let storage = List.fold(transferIterator, transferParameter, storage);
+    (([]: list(operation)), storage);
+};
+let main = ((parameter, storage): entrypointParameter): entrypointReturn => {
+    switch (parameter) {
+        | Transfer(transferParameter) => transfer((transferParameter, storage))
+    }
+}

src/test/contracts/id.ligo

@@ -0,0 +1,159 @@
+type id is int
+
+type id_details is
+  record [
+    owner: address;
+    controller: address;
+    profile: bytes;
+  ]
+
+type buy is
+  record [
+    profile: bytes;
+    initial_controller: option(address);
+  ]
+
+type update_owner is
+  record [
+    id: id;
+    new_owner: address;
+  ]
+
+type update_details is
+  record [
+    id: id;
+    new_profile: option(bytes);
+    new_controller: option(address);
+  ]
+
+type action is
+  | Buy of buy
+  | Update_owner of update_owner
+  | Update_details of update_details
+  | Skip of unit
+
+(* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. *)
+type storage is
+  record [
+    identities: big_map (id, id_details);
+    next_id: int;
+    name_price: tez;
+    skip_price: tez;
+  ]
+
+(** Preliminary thoughts on ids:
+
+I very much like the simplicity of http://gurno.com/adam/mne/.
+5 three letter words means you have a 15 character identity, not actually more
+annoying than an IP address and a lot more memorable than the raw digits. This
+can be stored as a single integer which is then translated into the corresponding
+series of 5 words.
+
+I in general like the idea of having a 'skip' mechanism, but it does need to cost
+something so people don't eat up the address space. 256 ^ 5 means you have a lot
+of address space, but if people troll by skipping a lot that could be eaten up.
+Should probably do some napkin calculations for how expensive skipping needs to
+be to deter people from doing it just to chew up address space.
+*)
+
+function buy (const parameter : buy; const storage : storage) : list(operation) * storage is
+  begin
+    if amount = storage.name_price
+    then skip
+    else failwith("Incorrect amount paid.");
+    const profile : bytes = parameter.profile;
+    const initial_controller : option(address) = parameter.initial_controller;
+    var identities : big_map (id, id_details) := storage.identities;
+    const new_id : int = storage.next_id;
+    const controller : address =
+      case initial_controller of
+        Some(addr) -> addr
+      | None -> sender
+      end;
+    const new_id_details: id_details =
+      record [
+              owner = sender ;
+              controller = controller ;
+              profile = profile ;
+      ];
+    identities[new_id] := new_id_details;
+  end with ((nil : list(operation)), storage with record [
+                              identities = identities;
+                              next_id = new_id + 1;
+                              ])
+
+function update_owner (const parameter : update_owner; const storage : storage) :
+         list(operation) * storage is
+  begin
+    if (amount =/= 0mutez)
+    then
+      begin
+        failwith("Updating owner doesn't cost anything.");
+      end
+    else skip;
+    const id : int = parameter.id;
+    const new_owner : address = parameter.new_owner;
+    var identities : big_map (id, id_details) := storage.identities;
+    const id_details : id_details =
+      case identities[id] of
+        Some(id_details) -> id_details
+      | None -> (failwith("This ID does not exist."): id_details)
+      end;
+    if sender = id_details.owner
+    then skip;
+    else failwith("You are not the owner of this ID.");
+    id_details.owner := new_owner;
+    identities[id] := id_details;
+  end with ((nil: list(operation)), storage with record [ identities = identities; ])
+
+function update_details (const parameter : update_details; const storage : storage ) :
+         list(operation) * storage is
+  begin
+    if (amount =/= 0mutez)
+    then failwith("Updating details doesn't cost anything.")
+    else skip;
+    const id : int = parameter.id;
+    const new_profile : option(bytes) = parameter.new_profile;
+    const new_controller : option(address) = parameter.new_controller;
+    const identities : big_map (id, id_details) = storage.identities;
+    const id_details: id_details =
+      case identities[id] of
+        Some(id_details) -> id_details
+      | None -> (failwith("This ID does not exist."): id_details)
+      end;
+    if (sender = id_details.controller) or (sender = id_details.owner)
+    then skip;
+    else failwith("You are not the owner or controller of this ID.");
+    const owner: address = id_details.owner;
+    const profile: bytes =
+      case new_profile of
+        None -> (* Default *) id_details.profile
+      | Some(new_profile) -> new_profile
+      end;
+    const controller: address =
+    case new_controller of
+      None -> (* Default *) id_details.controller
+    | Some(new_controller) -> new_controller
+    end;
+    id_details.owner := owner;
+    id_details.controller := controller;
+    id_details.profile := profile;
+    identities[id] := id_details;
+  end with ((nil: list(operation)), storage with record [ identities = identities; ])
+
+(* Let someone skip the next identity so nobody has to take one that's undesirable *)
+function skip_ (const p: unit; const storage: storage) : list(operation) * storage is
+  begin
+    if amount = storage.skip_price
+    then skip
+    else failwith("Incorrect amount paid.");
+  end with ((nil: list(operation)), storage with record [ next_id = storage.next_id + 1; ])
+
+function main (const action : action; const storage : storage) : list(operation) * storage is
+  case action of
+  | Buy(b) -> buy (b, storage)
+  | Update_owner(uo) -> update_owner (uo, storage)
+  | Update_details(ud) -> update_details (ud, storage)
+  | Skip(s) -> skip_ (unit, storage)
+  end;

src/test/contracts/id.mligo

@@ -6,9 +6,21 @@ type id_details = {
   profile: bytes
 }
 
-type buy = bytes * address option
+type buy = {
-type update_owner = id * address
+  profile: bytes;
-type update_details = id * bytes option * address option
+  initial_controller: address option;
+}
+
+type update_owner = {
+  id: id;
+  new_owner: address;
+}
+
+type update_details = {
+  id: id;
+  new_profile: bytes option;
+  new_controller: address option;
+}
 
 type action =
 | Buy of buy
@@ -19,7 +31,14 @@ type action =
 (* The prices kept in storage can be changed by bakers, though they
    should only be adjusted down over time, not up. *)
 
-type storage = (id, id_details) big_map * int * (tez * tez)
+(* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. *)
+type storage = {
+  identities: (id, id_details) big_map;
+  next_id: int;
+  name_price: tez;
+  skip_price: tez;
+}
 
 type return = operation list * storage
 
@@ -38,12 +57,16 @@ a lot that could be eaten up.  Should probably do some napkin
 calculations for how expensive skipping needs to be to deter people
 from doing it just to chew up address space.  *)
 
-let buy (parameter, storage: (bytes * address option) * storage) =
+let buy (parameter, storage: buy * storage) =
   let void: unit = 
-    if Tezos.amount <> storage.2.0
+    if amount = storage.name_price 
-    then (failwith "Incorrect amount paid.": unit) in
+    then () 
-  let profile, initial_controller = parameter in
+    else (failwith "Incorrect amount paid.": unit)
-  let identities, new_id, prices = storage in
+  in
+  let profile = parameter.profile in
+  let initial_controller = parameter.initial_controller in
+  let identities = storage.identities in
+  let new_id = storage.next_id in
   let controller: address =
     match initial_controller with
     | Some addr -> addr
@@ -54,74 +77,84 @@ let buy (parameter, storage: (bytes * address option) * storage) =
     profile = profile} in
   let updated_identities : (id, id_details) big_map =
     Big_map.update new_id (Some new_id_details) identities
-  in ([]: operation list), (updated_identities, new_id + 1, prices)
+  in
+  ([]: operation list), {storage with identities = updated_identities;
+                         next_id = new_id + 1; 
+                        }
 
-let update_owner (parameter, storage : (id * address) * storage) =
+let update_owner (parameter, storage: update_owner * storage) =
-  if amount <> 0tez
+  if (amount <> 0mutez)
-  then (failwith "Updating owner doesn't cost anything.": return)
+  then (failwith "Updating owner doesn't cost anything.": (operation list) * storage)
   else
-    let id, new_owner = parameter in
+  let id = parameter.id in
-    let identities, last_id, prices = storage in
+  let new_owner = parameter.new_owner in
+  let identities = storage.identities in
   let current_id_details: id_details =
     match Big_map.find_opt id identities with
     | Some id_details -> id_details
-      | None -> (failwith "This ID does not exist." : id_details) in
+    | None -> (failwith "This ID does not exist.": id_details)
-    let is_allowed : bool =
+  in
-      if Tezos.sender = current_id_details.owner
+  let u : unit =
-      then true
+    if sender = current_id_details.owner
-      else (failwith "You are not the owner of this ID." : bool) in
+    then ()
+    else failwith "You are not the owner of this ID."
+  in
   let updated_id_details: id_details = {
     owner = new_owner;
     controller = current_id_details.controller;
-    profile = current_id_details.profile} in
+    profile = current_id_details.profile;
-  let updated_identities =
+  }
-    Big_map.update id (Some updated_id_details) identities
+  in
-  in ([]: operation list), (updated_identities, last_id, prices)
+  let updated_identities = Big_map.update id (Some updated_id_details) identities in
+  ([]: operation list), {storage with identities = updated_identities}
 
-let update_details (parameter, storage: (id * bytes option * address option) * storage) =
+let update_details (parameter, storage: update_details * storage) =
-  if Tezos.amount <> 0tez
+  if (amount <> 0mutez)
-  then
+  then (failwith "Updating details doesn't cost anything.": (operation list) * storage)
-    (failwith "Updating details doesn't cost anything." : return)
   else
-    let id, new_profile, new_controller = parameter in
+  let id = parameter.id in
-    let identities, last_id, prices = storage in
+  let new_profile = parameter.new_profile in
+  let new_controller = parameter.new_controller in
+  let identities = storage.identities in
   let current_id_details: id_details =
     match Big_map.find_opt id identities with
     | Some id_details -> id_details
-      | None -> (failwith "This ID does not exist.": id_details) in
+    | None -> (failwith "This ID does not exist.": id_details)
-    let is_allowed : bool =
+  in
-      if Tezos.sender = current_id_details.controller
+  let u : unit =
-         || Tezos.sender = current_id_details.owner
+    if (sender = current_id_details.controller) || (sender = current_id_details.owner)
-      then true
+    then ()
-      else
+    else failwith ("You are not the owner or controller of this ID.")
-        (failwith ("You are not the owner or controller of this ID.")
+  in
-         : bool) in
   let owner: address = current_id_details.owner in
   let profile: bytes =
     match new_profile with
     | None -> (* Default *) current_id_details.profile
-      | Some new_profile -> new_profile in
+    | Some new_profile -> new_profile
+  in
   let controller: address =
     match new_controller with
     | None -> (* Default *) current_id_details.controller
-      | Some new_controller -> new_controller in
+    | Some new_controller -> new_controller
+  in
   let updated_id_details: id_details = {
     owner = owner;
     controller = controller;
-        profile = profile} in
+    profile = profile;
+  }
+  in
   let updated_identities: (id, id_details) big_map  =
-    Big_map.update id (Some updated_id_details) identities
+    Big_map.update id (Some updated_id_details) identities in
-  in ([]: operation list), (updated_identities, last_id, prices)
+  ([]: operation list), {storage with identities = updated_identities}
-
-(* Let someone skip the next identity so nobody has to take one that's
-undesirable *)
 
+(* Let someone skip the next identity so nobody has to take one that's undesirable *)
 let skip (p,storage: unit * storage) =
   let void: unit =
-    if Tezos.amount <> storage.2.1
+    if amount = storage.skip_price
-    then (failwith "Incorrect amount paid." : unit) in
+    then ()
-  let identities, last_id, prices = storage in
+    else failwith "Incorrect amount paid."
-  ([]: operation list), (identities, last_id + 1, prices)
+  in
+  ([]: operation list), {storage with next_id = storage.next_id + 1}
 
 let main (action, storage : action * storage) : return =
   match action with

src/test/contracts/id.religo

@@ -0,0 +1,167 @@
+type id = int
+
+type id_details = {
+  owner: address,
+  controller: address,
+  profile: bytes,
+}
+
+type buy = {
+  profile: bytes,
+  initial_controller: option(address),
+}
+
+type update_owner = {
+  id: id,
+  new_owner: address,
+}
+
+type update_details = {
+  id: id,
+  new_profile: option(bytes),
+  new_controller: option(address),
+}
+
+type action =
+| Buy(buy)
+| Update_owner(update_owner)
+| Update_details(update_details)
+| Skip(unit)
+
+/* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. */
+type storage = {
+  identities: big_map (id, id_details),
+  next_id: int,
+  name_price: tez,
+  skip_price: tez,
+}
+
+/** Preliminary thoughts on ids:
+
+I very much like the simplicity of http://gurno.com/adam/mne/.
+5 three letter words means you have a 15 character identity, not actually more
+annoying than an IP address and a lot more memorable than the raw digits. This
+can be stored as a single integer which is then translated into the corresponding
+series of 5 words.
+
+I in general like the idea of having a 'skip' mechanism, but it does need to cost
+something so people don't eat up the address space. 256 ^ 5 means you have a lot
+of address space, but if people troll by skipping a lot that could be eaten up.
+Should probably do some napkin calculations for how expensive skipping needs to
+be to deter people from doing it just to chew up address space.
+*/
+
+let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => {
+  let void: unit =
+    if (amount == storage.name_price) { (); }
+    else { failwith("Incorrect amount paid."); };
+  let profile = parameter.profile;
+  let initial_controller = parameter.initial_controller;
+  let identities = storage.identities;
+  let new_id = storage.next_id;
+  let controller: address =
+    switch (initial_controller) {
+      | Some(addr) => addr
+      | None => sender
+    };
+  let new_id_details: id_details = {
+    owner : sender,
+    controller : controller,
+    profile : profile,
+  };
+  let updated_identities: big_map (id, id_details) =
+    Big_map.update(new_id, Some(new_id_details), identities);
+  (([]: list(operation)), { ...storage,
+                           identities : updated_identities,
+                           next_id : new_id + 1,
+                        });
+  };
+
+let update_owner = ((parameter, storage): (update_owner, storage)) : (list(operation), storage) => {
+  let void: unit =
+    if (amount != 0mutez) {
+      failwith("Updating owner doesn't cost anything.");
+    }
+    else { (); };
+  let id : int = parameter.id;
+  let new_owner = parameter.new_owner;
+  let identities = storage.identities;
+  let current_id_details: id_details =
+    switch (Big_map.find_opt(id, identities)) {
+      | Some(id_details) => id_details
+      | None => (failwith("This ID does not exist."): id_details)
+    };
+  let u: unit =
+    if (sender == current_id_details.owner) { (); }
+    else { failwith("You are not the owner of this ID."); };
+  let updated_id_details: id_details = {
+    owner : new_owner,
+    controller : current_id_details.controller,
+    profile : current_id_details.profile,
+  };
+  let updated_identities = Big_map.update(id, (Some updated_id_details), identities);
+  (([]: list(operation)), { ...storage, identities : updated_identities });
+  };
+
+let update_details = ((parameter, storage): (update_details, storage)) :
+                   (list(operation), storage) => {
+  let void : unit = 
+    if (amount != 0mutez) {
+      failwith("Updating details doesn't cost anything.");
+    }
+    else { (); };
+  let id = parameter.id;
+  let new_profile = parameter.new_profile;
+  let new_controller = parameter.new_controller;
+  let identities = storage.identities;
+  let current_id_details: id_details =
+    switch (Big_map.find_opt(id, identities)) {
+      | Some(id_details) => id_details
+      | None => (failwith("This ID does not exist."): id_details)
+    };
+  let u: unit =
+    if ((sender != current_id_details.controller) &&
+        (sender != current_id_details.owner)) {
+      failwith ("You are not the owner or controller of this ID.")
+    }
+    else { (); };
+  let owner: address = current_id_details.owner;
+  let profile: bytes =
+    switch (new_profile) {
+      | None => /* Default */ current_id_details.profile
+      | Some(new_profile) => new_profile
+    };
+  let controller: address =
+    switch (new_controller) {
+      | None => /* Default */ current_id_details.controller
+      | Some new_controller => new_controller
+    };
+  let updated_id_details: id_details = {
+    owner : owner,
+    controller : controller,
+    profile : profile,
+  };
+  let updated_identities: big_map (id, id_details) =
+    Big_map.update(id, (Some updated_id_details), identities);
+  (([]: list(operation)), { ...storage, identities : updated_identities });
+  };
+
+/* Let someone skip the next identity so nobody has to take one that's undesirable */
+let skip = ((p,storage): (unit, storage)) => {
+  let void : unit =
+    if (amount != storage.skip_price) {
+      failwith("Incorrect amount paid.");
+    }
+    else { (); };
+  (([]: list(operation)), { ...storage, next_id : storage.next_id + 1 });
+  };
+
+let main = ((action, storage): (action, storage)) : (list(operation), storage) => {
+  switch (action) {
+    | Buy(b) => buy((b, storage))
+    | Update_owner(uo) => update_owner((uo, storage))
+    | Update_details ud => update_details((ud, storage))
+    | Skip s => skip(((), storage))
+  };
+};

src/test/examples/cameligo/arithmetic-contract.ligo

@@ -15,6 +15,9 @@
   evaluateFunction:
     entrypoint: add
     parameters: 5, 6
+  generateDeployScript:
+    entrypoint: main
+    storage: 0
 *_*)
 type storage = int
 

src/test/examples/cameligo/id.mligo

@@ -0,0 +1,243 @@
+(*_*
+  name: ID Contract (CameLIGO)
+  language: cameligo
+  compile:
+    entrypoint: main
+  dryRun:
+    entrypoint: main
+    parameters: |
+      Buy (  
+        {
+          profile=0x0501000000026869;
+          initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address))
+        }
+      )
+    storage: |
+      {
+        identities=Big_map.literal[
+          (1, 
+          {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
+          controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address);
+          profile=0x0501000000026869}
+          );
+        ]; 
+        next_id=2; 
+        name_price=0tez; 
+        skip_price=333mutez 
+      }
+  deploy:
+    entrypoint: main
+    storage: |
+      {
+        identities=Big_map.literal[
+          (1,
+          {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
+           controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address);
+           profile=0x0501000000026869}
+          );
+         ]; 
+        next_id=2; 
+        name_price=10tez; 
+        skip_price=333mutez
+      }
+  evaluateValue:
+    entrypoint: ""
+  evaluateFunction:
+    entrypoint: buy
+    parameters: |
+      { 
+        profile=0x0501000000026869; 
+        initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address))
+      }, 
+  
+      { 
+        identities=Big_map.literal[
+          (1,
+           {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); 
+            controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); 
+            profile=0x0501000000026869}
+          );
+        ]; 
+        next_id=2; 
+        name_price=0tez; 
+        skip_price=333mutez
+      }
+*_*)
+
+type id = int
+
+type id_details = {
+  owner: address;
+  controller: address;
+  profile: bytes;
+}
+
+type buy = {
+  profile: bytes;
+  initial_controller: address option;
+}
+
+type update_owner = {
+  id: id;
+  new_owner: address;
+}
+
+type update_details = {
+  id: id;
+  new_profile: bytes option;
+  new_controller: address option;
+}
+
+type action =
+| Buy of buy
+| Update_owner of update_owner
+| Update_details of update_details
+| Skip of unit
+
+(* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. *)
+type storage = {
+  identities: (id, id_details) big_map;
+  next_id: int;
+  name_price: tez;
+  skip_price: tez;
+}
+
+(** Preliminary thoughts on ids:
+
+I very much like the simplicity of http://gurno.com/adam/mne/
+
+Five three letter words means you have a 15 character identity, not actually more
+annoying than an IP address and a lot more memorable than the raw digits. This
+can be stored as a single integer which is then translated into the corresponding
+series of 5 words.
+
+I, in general like the idea of having a 'skip' mechanism, but it does need to cost
+something so people don't eat up the address space. 256 ^ 5 means you have a lot
+of address space, but if people troll by skipping a lot that could be eaten up.
+Should probably do some napkin calculations for how expensive skipping needs to
+be to deter people from doing it just to chew up address space.
+*)
+
+let buy (parameter, storage: buy * storage) =
+  let void: unit = 
+    if amount = storage.name_price 
+    then () 
+    else (failwith "Incorrect amount paid.": unit)
+  in
+  let profile = parameter.profile in
+  let initial_controller = parameter.initial_controller in
+  let identities = storage.identities in
+  let new_id = storage.next_id in
+  let controller: address =
+    match initial_controller with
+    | Some addr -> addr
+    | None -> sender
+  in
+  let new_id_details: id_details = {
+    owner = sender ;
+    controller = controller ;
+    profile = profile ;
+  }
+  in
+  let updated_identities: (id, id_details) big_map =
+    Big_map.update new_id (Some new_id_details) identities
+  in
+  ([]: operation list), {identities = updated_identities;
+                         next_id = new_id + 1; 
+                         name_price = storage.name_price;
+                         skip_price = storage.skip_price;
+                        }
+
+let update_owner (parameter, storage: update_owner * storage) =
+  if (amount <> 0mutez)
+  then (failwith "Updating owner doesn't cost anything.": (operation list) * storage)
+  else
+  let id = parameter.id in
+  let new_owner = parameter.new_owner in
+  let identities = storage.identities in
+  let current_id_details: id_details =
+    match Big_map.find_opt id identities with
+    | Some id_details -> id_details
+    | None -> (failwith "This ID does not exist.": id_details)
+  in
+  let is_allowed: bool =
+    if sender = current_id_details.owner
+    then true
+    else (failwith "You are not the owner of this ID.": bool)
+  in
+  let updated_id_details: id_details = {
+    owner = new_owner;
+    controller = current_id_details.controller;
+    profile = current_id_details.profile;
+  }
+  in
+  let updated_identities = Big_map.update id (Some updated_id_details) identities in
+  ([]: operation list), {identities = updated_identities; 
+                         next_id = storage.next_id;
+                         name_price = storage.name_price;
+                         skip_price = storage.skip_price;
+                        }
+
+let update_details (parameter, storage: update_details * storage) =
+  if (amount <> 0mutez)
+  then (failwith "Updating details doesn't cost anything.": (operation list) * storage)
+  else
+  let id = parameter.id in
+  let new_profile = parameter.new_profile in
+  let new_controller = parameter.new_controller in
+  let identities = storage.identities in
+  let current_id_details: id_details =
+    match Big_map.find_opt id identities with
+    | Some id_details -> id_details
+    | None -> (failwith "This ID does not exist.": id_details)
+  in
+  let is_allowed: bool =
+    if (sender = current_id_details.controller) || (sender = current_id_details.owner)
+    then true
+    else (failwith ("You are not the owner or controller of this ID."): bool)
+  in
+  let owner: address = current_id_details.owner in
+  let profile: bytes =
+    match new_profile with
+    | None -> (* Default *) current_id_details.profile
+    | Some new_profile -> new_profile
+  in
+  let controller: address =
+    match new_controller with
+    | None -> (* Default *) current_id_details.controller
+    | Some new_controller -> new_controller
+  in
+  let updated_id_details: id_details = {
+    owner = owner;
+    controller = controller;
+    profile = profile;
+  }
+  in
+  let updated_identities: (id, id_details) big_map  =
+    Big_map.update id (Some updated_id_details) identities in
+  ([]: operation list), {identities = updated_identities;
+                         next_id = storage.next_id;
+                         name_price = storage.name_price;
+                         skip_price = storage.skip_price;
+                        }
+
+(* Let someone skip the next identity so nobody has to take one that's undesirable *)
+let skip (p,storage: unit * storage) =
+  let void: unit =
+    if amount = storage.skip_price
+    then ()
+    else (failwith "Incorrect amount paid.": unit)
+  in
+  ([]: operation list), {identities = storage.identities;
+                         next_id = storage.next_id + 1;
+                         name_price = storage.name_price;
+                         skip_price = storage.skip_price;
+                        }
+
+let main (action, storage: action * storage) : operation list * storage =
+  match action with
+  | Buy b -> buy (b, storage)
+  | Update_owner uo -> update_owner (uo, storage)
+  | Update_details ud -> update_details (ud, storage)
+  | Skip s -> skip ((), storage)

src/test/examples/pascaligo/arithmetic-contract.ligo

@@ -15,6 +15,9 @@
   evaluateFunction:
     entrypoint: add
     parameters: (5, 6)
+  generateDeployScript:
+    entrypoint: main
+    storage: 0
 *_*)
 // variant defining pseudo multi-entrypoint actions
 type action is

src/test/examples/pascaligo/id.ligo

@@ -0,0 +1,242 @@
+(*_*
+  name: ID Contract (PascaLIGO)
+  language: pascaligo
+  compile:
+    entrypoint: main
+  dryRun:
+    entrypoint: main
+    parameters: |
+      Buy (
+        record [
+          profile=0x0501000000026869;
+          initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address))
+        ]
+      )
+    storage: |
+      record [
+        identities=big_map[
+          1->record 
+          [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
+           controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address);
+           profile=0x0501000000026869]
+        ];
+        next_id=2;
+        name_price=0tez;
+        skip_price=50mutez;
+      ]
+  deploy:
+    entrypoint: main
+    storage: |
+      record [
+        identities=big_map[
+          1->record
+          [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
+           controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address);
+           profile=0x0501000000026869]
+        ];
+        next_id=2; 
+        name_price=0tez;
+        skip_price=50mutez;
+      ]
+  evaluateValue:
+    entrypoint: ""
+  evaluateFunction:
+    entrypoint: buy
+    parameters: |
+      (
+        record [
+          profile=0x0501000000026869;
+          initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address))
+        ],
+
+        record [  identities=big_map[
+          1->record
+          [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address);
+           controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address);
+           profile=0x0501000000026869]
+          ];
+          next_id=2;
+          name_price=0tez;
+          skip_price=333mutez;
+        ]
+      )
+*_*)
+
+type id is int
+
+type id_details is
+  record [
+    owner: address;
+    controller: address;
+    profile: bytes;
+  ]
+
+type buy is
+  record [
+    profile: bytes;
+    initial_controller: option(address);
+  ]
+
+type update_owner is
+  record [
+    id: id;
+    new_owner: address;
+  ]
+
+type update_details is
+  record [
+    id: id;
+    new_profile: option(bytes);
+    new_controller: option(address);
+  ]
+
+type action is
+  | Buy of buy
+  | Update_owner of update_owner
+  | Update_details of update_details
+  | Skip of unit
+
+(* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. *)
+type storage is
+  record [
+    identities: big_map (id, id_details);
+    next_id: int;
+    name_price: tez;
+    skip_price: tez;
+  ]
+
+(** Preliminary thoughts on ids:
+
+I very much like the simplicity of http://gurno.com/adam/mne/.
+5 three letter words means you have a 15 character identity, not actually more
+annoying than an IP address and a lot more memorable than the raw digits. This
+can be stored as a single integer which is then translated into the corresponding
+series of 5 words.
+
+I in general like the idea of having a 'skip' mechanism, but it does need to cost
+something so people don't eat up the address space. 256 ^ 5 means you have a lot
+of address space, but if people troll by skipping a lot that could be eaten up.
+Should probably do some napkin calculations for how expensive skipping needs to
+be to deter people from doing it just to chew up address space.
+*)
+
+function buy (const parameter : buy; const storage : storage) : list(operation) * storage is
+  begin
+    if amount = storage.name_price
+    then skip
+    else failwith("Incorrect amount paid.");
+    const profile : bytes = parameter.profile;
+    const initial_controller : option(address) = parameter.initial_controller;
+    var identities : big_map (id, id_details) := storage.identities;
+    const new_id : int = storage.next_id;
+    const controller : address =
+      case initial_controller of
+        Some(addr) -> addr
+      | None -> sender
+      end;
+    const new_id_details: id_details =
+      record [
+              owner = sender ;
+              controller = controller ;
+              profile = profile ;
+      ];
+    identities[new_id] := new_id_details;
+  end with ((nil : list(operation)), record [
+                              identities = identities;
+                              next_id = new_id + 1;
+                              name_price = storage.name_price;
+                              skip_price = storage.skip_price;
+                              ])
+
+function update_owner (const parameter : update_owner; const storage : storage) :
+         list(operation) * storage is
+  begin
+    if (amount =/= 0mutez)
+    then
+      begin
+        failwith("Updating owner doesn't cost anything.");
+      end
+    else skip;
+    const id : int = parameter.id;
+    const new_owner : address = parameter.new_owner;
+    var identities : big_map (id, id_details) := storage.identities;
+    const id_details : id_details =
+      case identities[id] of
+        Some(id_details) -> id_details
+      | None -> (failwith("This ID does not exist."): id_details)
+      end;
+    var is_allowed : bool := False;
+    if sender = id_details.owner
+    then is_allowed := True
+    else failwith("You are not the owner of this ID.");
+    id_details.owner := new_owner;
+    identities[id] := id_details;
+  end with ((nil: list(operation)), record [
+                                     identities = identities;
+                                     next_id = storage.next_id;
+                                     name_price = storage.name_price;
+                                     skip_price = storage.skip_price;
+                                   ])
+
+function update_details (const parameter : update_details; const storage : storage ) :
+         list(operation) * storage is
+  begin
+    if (amount =/= 0mutez)
+    then failwith("Updating details doesn't cost anything.")
+    else skip;
+    const id : int = parameter.id;
+    const new_profile : option(bytes) = parameter.new_profile;
+    const new_controller : option(address) = parameter.new_controller;
+    const identities : big_map (id, id_details) = storage.identities;
+    const id_details: id_details =
+      case identities[id] of
+        Some(id_details) -> id_details
+      | None -> (failwith("This ID does not exist."): id_details)
+      end;
+    var is_allowed : bool := False;
+    if (sender = id_details.controller) or (sender = id_details.owner)
+    then is_allowed := True
+    else failwith("You are not the owner or controller of this ID.");
+    const owner: address = id_details.owner;
+    const profile: bytes =
+      case new_profile of
+        None -> (* Default *) id_details.profile
+      | Some(new_profile) -> new_profile
+      end;
+    const controller: address =
+    case new_controller of
+      None -> (* Default *) id_details.controller
+    | Some(new_controller) -> new_controller
+    end;
+    id_details.owner := owner;
+    id_details.controller := controller;
+    id_details.profile := profile;
+    identities[id] := id_details;
+  end with ((nil: list(operation)), record [
+                                     identities = identities;
+                                     next_id = storage.next_id;
+                                     name_price = storage.name_price;
+                                     skip_price = storage.skip_price;
+                                    ])
+
+(* Let someone skip the next identity so nobody has to take one that's undesirable *)
+function skip_ (const p: unit; const storage: storage) : list(operation) * storage is
+  begin
+    if amount = storage.skip_price
+    then skip
+    else failwith("Incorrect amount paid.");
+  end with ((nil: list(operation)), record [
+                                     identities = storage.identities;
+                                     next_id = storage.next_id + 1;
+                                     name_price = storage.name_price;
+                                     skip_price = storage.skip_price;
+                                   ])
+
+function main (const action : action; const storage : storage) : list(operation) * storage is
+  case action of
+  | Buy(b) -> buy (b, storage)
+  | Update_owner(uo) -> update_owner (uo, storage)
+  | Update_details(ud) -> update_details (ud, storage)
+  | Skip(s) -> skip_ (unit, storage)
+  end;

src/test/examples/reasonligo/arithmetic-contract.ligo

@@ -15,6 +15,9 @@
   evaluateFunction:
     entrypoint: add
     parameters: (5, 6)
+  generateDeployScript:
+    entrypoint: main
+    storage: 0
 *_*)
 type storage = int;
 

src/test/examples/reasonligo/id.religo

@@ -0,0 +1,248 @@
+/* (*_*
+  name: ID Contract (ReasonLIGO)
+  language: reasonligo
+  compile:
+    entrypoint: main
+  dryRun:
+    entrypoint: main
+    parameters: |
+      Buy (
+        {
+          profile: 0x0501000000026869,
+          initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address))
+        }
+      )
+    storage: |
+      {
+        identities:Big_map.literal([
+          (1,
+           {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address),
+           controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869}
+          )
+        ]),
+        next_id:2,
+        name_price:0tez,
+        skip_price:333mutez
+      }
+  deploy:
+    entrypoint: main
+    storage: |
+      {
+        identities:Big_map.literal([
+          (1,
+           {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869}
+          )
+        ]),
+        next_id:2,
+        name_price:10tez,
+        skip_price:333mutez
+      }
+  evaluateValue:
+    entrypoint: ""
+  evaluateFunction:
+    entrypoint: buy
+    parameters: |
+      (
+        {
+          profile: 0x0501000000026869,
+          initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address))
+        },
+        {
+          identities:Big_map.literal([
+            (1,
+             {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address),
+              controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address),
+              profile:0x0501000000026869}
+            )
+          ]),
+          next_id:2,
+          name_price:0tez,
+          skip_price:333mutez
+        }
+      )
+*_*) */
+
+type id = int
+
+type id_details = {
+  owner: address,
+  controller: address,
+  profile: bytes,
+}
+
+type buy = {
+  profile: bytes,
+  initial_controller: option(address),
+}
+
+type update_owner = {
+  id: id,
+  new_owner: address,
+}
+
+type update_details = {
+  id: id,
+  new_profile: option(bytes),
+  new_controller: option(address),
+}
+
+type action =
+| Buy(buy)
+| Update_owner(update_owner)
+| Update_details(update_details)
+| Skip(unit)
+
+/* The prices kept in storage can be changed by bakers, though they should only be
+   adjusted down over time, not up. */
+type storage = {
+  identities: big_map (id, id_details),
+  next_id: int,
+  name_price: tez,
+  skip_price: tez,
+}
+
+/** Preliminary thoughts on ids:
+
+I very much like the simplicity of http://gurno.com/adam/mne/.
+5 three letter words means you have a 15 character identity, not actually more
+annoying than an IP address and a lot more memorable than the raw digits. This
+can be stored as a single integer which is then translated into the corresponding
+series of 5 words.
+
+I in general like the idea of having a 'skip' mechanism, but it does need to cost
+something so people don't eat up the address space. 256 ^ 5 means you have a lot
+of address space, but if people troll by skipping a lot that could be eaten up.
+Should probably do some napkin calculations for how expensive skipping needs to
+be to deter people from doing it just to chew up address space.
+*/
+
+let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => {
+  let void: unit =
+    if (amount == storage.name_price) { (); }
+    else { failwith("Incorrect amount paid."); };
+  let profile = parameter.profile;
+  let initial_controller = parameter.initial_controller;
+  let identities = storage.identities;
+  let new_id = storage.next_id;
+  let controller: address =
+    switch (initial_controller) {
+      | Some(addr) => addr
+      | None => sender
+    };
+  let new_id_details: id_details = {
+    owner : sender,
+    controller : controller,
+    profile : profile,
+  };
+  let updated_identities: big_map (id, id_details) =
+    Big_map.update(new_id, Some(new_id_details), identities);
+  (([]: list(operation)), {
+                           identities : updated_identities,
+                           next_id : new_id + 1,
+                           name_price : storage.name_price,
+                           skip_price : storage.skip_price,
+                        });
+  };
+
+let update_owner = ((parameter, storage): (update_owner, storage)) : (list(operation), storage) => {
+  let void: unit =
+    if (amount != 0mutez) {
+      failwith("Updating owner doesn't cost anything.");
+    }
+    else { (); };
+  let id : int = parameter.id;
+  let new_owner = parameter.new_owner;
+  let identities = storage.identities;
+  let current_id_details: id_details =
+    switch (Big_map.find_opt(id, identities)) {
+      | Some(id_details) => id_details
+      | None => (failwith("This ID does not exist."): id_details)
+    };
+  let is_allowed: bool =
+    if (sender == current_id_details.owner) { true; }
+    else { (failwith("You are not the owner of this ID."): bool); };
+  let updated_id_details: id_details = {
+    owner : new_owner,
+    controller : current_id_details.controller,
+    profile : current_id_details.profile,
+  };
+  let updated_identities = Big_map.update(id, (Some updated_id_details), identities);
+  (([]: list(operation)), {
+                           identities : updated_identities,
+                           next_id : storage.next_id,
+                           name_price : storage.name_price,
+                           skip_price : storage.skip_price,
+                        });
+  };
+
+let update_details = ((parameter, storage): (update_details, storage)) :
+                   (list(operation), storage) => {
+  let void : unit =
+    if (amount != 0mutez) {
+      failwith("Updating details doesn't cost anything.");
+    }
+    else { (); };
+  let id = parameter.id;
+  let new_profile = parameter.new_profile;
+  let new_controller = parameter.new_controller;
+  let identities = storage.identities;
+  let current_id_details: id_details =
+    switch (Big_map.find_opt(id, identities)) {
+      | Some(id_details) => id_details
+      | None => (failwith("This ID does not exist."): id_details)
+    };
+  let is_allowed: bool =
+    if ((sender != current_id_details.controller) &&
+        (sender != current_id_details.owner)) {
+      (failwith ("You are not the owner or controller of this ID."): bool)
+    }
+    else { true; };
+  let owner: address = current_id_details.owner;
+  let profile: bytes =
+    switch (new_profile) {
+      | None => /* Default */ current_id_details.profile
+      | Some(new_profile) => new_profile
+    };
+  let controller: address =
+    switch (new_controller) {
+      | None => /* Default */ current_id_details.controller
+      | Some new_controller => new_controller
+    };
+  let updated_id_details: id_details = {
+    owner : owner,
+    controller : controller,
+    profile : profile,
+  };
+  let updated_identities: big_map (id, id_details) =
+    Big_map.update(id, (Some updated_id_details), identities);
+  (([]: list(operation)), {
+                            identities : updated_identities,
+                            next_id : storage.next_id,
+                            name_price : storage.name_price,
+                            skip_price : storage.skip_price,
+                          });
+  };
+
+/* Let someone skip the next identity so nobody has to take one that's undesirable */
+let skip = ((p,storage): (unit, storage)) => {
+  let void : unit =
+    if (amount != storage.skip_price) {
+      failwith("Incorrect amount paid.");
+    }
+    else { (); };
+  (([]: list(operation)), {
+                            identities : storage.identities,
+                            next_id : storage.next_id + 1,
+                            name_price : storage.name_price,
+                            skip_price : storage.skip_price,
+                          });
+  };
+
+let main = ((action, storage): (action, storage)) : (list(operation), storage) => {
+  switch (action) {
+    | Buy(b) => buy((b, storage))
+    | Update_owner(uo) => update_owner((uo, storage))
+    | Update_details ud => update_details((ud, storage))
+    | Skip s => skip(((), storage))
+  };
+};

src/test/hash_lock_tests.ml

@@ -50,7 +50,7 @@ let empty_message = e_lambda (Var.of_name "arguments")
 
 
 let commit () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in
   let%bind lock_time = mk_time "2000-01-02T00:10:11Z" in
   let test_hash_raw = sha_256_hash (Bytes.of_string "hello world") in
@@ -79,12 +79,12 @@ let commit () =
       ~sender:first_contract
       ()
   in
-  expect_eq ~options program "commit"
+  expect_eq ~options (program, state) "commit"
     (e_pair salted_hash init_storage) (e_pair empty_op_list post_storage)
 
 (* Test that the contract fails if we haven't committed before revealing the answer *)
 let reveal_no_commit () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
                             ("message", empty_message)]
@@ -95,13 +95,13 @@ let reveal_no_commit () =
                                                               ("salted_hash", (t_bytes ()))])
   in
   let init_storage = storage test_hash true pre_commits in
-  expect_string_failwith program "reveal"
+  expect_string_failwith (program, state) "reveal"
     (e_pair reveal init_storage)
     "You have not made a commitment to hash against yet."
 
 (* Test that the contract fails if our commit isn't 24 hours old yet *)
 let reveal_young_commit () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
                             ("message", empty_message)]
@@ -128,13 +128,13 @@ let reveal_young_commit () =
       ~sender:first_contract
       ()
   in
-  expect_string_failwith ~options program "reveal"
+  expect_string_failwith ~options (program, state) "reveal"
     (e_pair reveal init_storage)
     "It has not been 24 hours since your commit yet."
 
 (* Test that the contract fails if our reveal doesn't meet our commitment *)
 let reveal_breaks_commit () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
                             ("message", empty_message)]
@@ -160,13 +160,13 @@ let reveal_breaks_commit () =
       ~sender:first_contract
       ()
   in
-  expect_string_failwith ~options program "reveal"
+  expect_string_failwith ~options (program, state) "reveal"
     (e_pair reveal init_storage)
     "This reveal does not match your commitment."
 
 (* Test that the contract fails if we reveal the wrong bytes for the stored hash *)
 let reveal_wrong_commit () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello");
                             ("message", empty_message)]
@@ -192,13 +192,13 @@ let reveal_wrong_commit () =
       ~sender:first_contract
       ()
   in
-  expect_string_failwith ~options program "reveal"
+  expect_string_failwith ~options (program, state) "reveal"
     (e_pair reveal init_storage)
     "Your commitment did not match the storage hash."
 
 (* Test that the contract fails if we try to reuse it after unused flag changed *)
 let reveal_no_reuse () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello");
                             ("message", empty_message)]
@@ -224,13 +224,13 @@ let reveal_no_reuse () =
       ~sender:first_contract
       ()
   in
-  expect_string_failwith ~options program "reveal"
+  expect_string_failwith ~options (program, state) "reveal"
     (e_pair reveal init_storage)
     "This contract has already been used."
 
 (* Test that the contract executes successfully with valid commit-reveal *)
 let reveal () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let empty_message = empty_message in
   let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
                             ("message", empty_message)]
@@ -257,7 +257,7 @@ let reveal () =
       ~sender:first_contract
       ()
   in
-  expect_eq ~options program "reveal"
+  expect_eq ~options (program, state) "reveal"
     (e_pair reveal init_storage) (e_pair empty_op_list post_storage)
 
 let main = test_suite "Hashlock" [

src/test/id_tests.ml

@@ -33,16 +33,17 @@ let (first_owner , first_contract) =
   Protocol.Alpha_context.Contract.to_b58check kt , kt
 
 let buy_id () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ;
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
-                         e_int 1;
+                             ("next_id", e_int 1) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
   let new_addr = first_owner in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
@@ -54,28 +55,33 @@ let buy_id () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let param = e_pair owner_website (e_some (e_address new_addr)) in
+  let param = e_record_ez [("profile", owner_website) ;
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+                           ("initial_controller", (e_some (e_address new_addr))) ;
-                                         (e_int 1, id_details_2)]) ;
+                          ] in
-                              e_int 2;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                              e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
-  let%bind () = expect_eq ~options program "buy" 
+  let%bind () = expect_eq ~options (program, state) "buy" 
       (e_pair param storage) 
       (e_pair (e_list []) new_storage)
   in ok ()
 
 let buy_id_sender_addr () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ;
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
-                         e_int 1;
+                             ("next_id", e_int 1) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
   let new_addr = first_owner in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
@@ -87,43 +93,48 @@ let buy_id_sender_addr () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let param = e_pair owner_website (e_typed_none (t_address ())) in
+  let param = e_record_ez [("profile", owner_website) ;
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+                           ("initial_controller", (e_typed_none (t_address ())))] in
-                                         (e_int 1, id_details_2)]) ;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                              e_int 2;
+                                                   [(e_int 0, id_details_1) ;
-                              e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
-  let%bind () = expect_eq ~options program "buy" 
+  let%bind () = expect_eq ~options (program, state) "buy" 
       (e_pair param storage) 
       (e_pair (e_list []) new_storage)
   in ok ()
 
 (* Test that contract fails if we attempt to buy an ID for the wrong amount *)
 let buy_id_wrong_amount () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
                                   ("controller", e_address owner_addr) ;
                                   ("profile", owner_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ;
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
-                         e_int 1;
+                             ("next_id", e_int 1) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
   let new_addr = first_owner in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
       ~sender:first_contract
       ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
   in
-  let param = e_pair owner_website (e_some (e_address new_addr)) in
+  let param = e_record_ez [("profile", owner_website) ;
-  let%bind () = expect_string_failwith ~options program "buy" 
+                           ("initial_controller", (e_some (e_address new_addr)))] in
+  let%bind () = expect_string_failwith ~options (program, state) "buy" 
       (e_pair param storage)
       "Incorrect amount paid."
   in ok ()
 
 let update_details_owner () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -144,27 +155,31 @@ let update_details_owner () =
   let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
                                        ("controller", e_address new_addr) ;
                                        ("profile", new_website)] in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                                   [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                    (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                                         (e_int 1, id_details_2_diff)]) ;
+                                                   [(e_int 0, id_details_1) ;
-                             e_int 2;
+                                                    (e_int 1, id_details_2_diff)])) ;
-                             e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
   let details = e_bytes_string "ligolang.org" in
-  let param = e_tuple [e_int 1 ; 
+  let param = e_record_ez [("id", e_int 1) ;
-                       e_some details ;
+                       ("new_profile", e_some details) ;
-                       e_some (e_address new_addr)] in
+                       ("new_controller", e_some (e_address new_addr))] in
-  let%bind () = expect_eq ~options program "update_details"
+  let%bind () = expect_eq ~options (program, state) "update_details"
       (e_pair param storage)
       (e_pair (e_list []) new_storage)
   in ok ()
 
 let update_details_controller () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -185,28 +200,32 @@ let update_details_controller () =
   let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
                                        ("controller", e_address owner_addr) ;
                                        ("profile", new_website)] in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                                         (e_int 1, id_details_2_diff)]) ;
+                                                   [(e_int 0, id_details_1) ;
-                             e_int 2;
+                                                    (e_int 1, id_details_2_diff)])) ;
-                             e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
   let details = e_bytes_string "ligolang.org" in
-  let param = e_tuple [e_int 1 ; 
+  let param = e_record_ez [("id", e_int 1) ;
-                       e_some details ;
+                           ("new_profile", e_some details) ;
-                       e_some (e_address owner_addr)] in
+                           ("new_controller", e_some (e_address owner_addr))] in
-  let%bind () = expect_eq ~options program "update_details"
+  let%bind () = expect_eq ~options (program, state) "update_details"
       (e_pair param storage)
       (e_pair (e_list []) new_storage)
   in ok ()
 
 (* Test that contract fails when we attempt to update details of nonexistent ID *)
 let update_details_nonexistent () = 
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -224,23 +243,25 @@ let update_details_nonexistent () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                                   [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                    (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
   let details = e_bytes_string "ligolang.org" in
-  let param = e_tuple [e_int 2 ; 
+  let param = e_record_ez [("id", e_int 2) ;
-                       e_some details ;
+                           ("new_profile", e_some details) ;
-                       e_some (e_address owner_addr)] in
+                           ("new_controller", e_some (e_address owner_addr))] in
-  let%bind () = expect_string_failwith ~options program "update_details"
+  let%bind () = expect_string_failwith ~options (program, state) "update_details"
       (e_pair param storage)
       "This ID does not exist."
   in ok ()
 
 (* Test that contract fails when we attempt to update details from wrong addr *)
 let update_details_wrong_addr () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -257,23 +278,25 @@ let update_details_wrong_addr () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                                   [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                    (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
   in
   let details = e_bytes_string "ligolang.org" in
-  let param = e_tuple [e_int 0 ; 
+  let param = e_record_ez [("id", e_int 0) ;
-                       e_some details ;
+                           ("new_profile", e_some details) ;
-                       e_some (e_address owner_addr)] in
+                           ("new_controller", e_some (e_address owner_addr))] in
-  let%bind () = expect_string_failwith ~options program "update_details"
+  let%bind () = expect_string_failwith ~options (program, state) "update_details"
       (e_pair param storage)
       "You are not the owner or controller of this ID."
   in ok ()
 
 (* Test that giving none on both profile and controller address is a no-op *)
 let update_details_unchanged () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -291,21 +314,23 @@ let update_details_unchanged () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let param = e_tuple [e_int 1 ; 
+  let param = e_record_ez [("id", e_int 1) ;
-                       e_typed_none (t_bytes ()) ;
+                           ("new_profile", e_typed_none (t_bytes ())) ;
-                       e_typed_none (t_address ())] in
+                           ("new_controller", e_typed_none (t_address ()))] in
-  let%bind () = expect_eq ~options program "update_details"
+  let%bind () = expect_eq ~options (program, state) "update_details"
       (e_pair param storage)
       (e_pair (e_list []) storage)
   in ok ()
 
 let update_owner () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -326,25 +351,30 @@ let update_owner () =
   let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
                                        ("controller", e_address new_addr) ;
                                        ("profile", new_website)] in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                                         (e_int 1, id_details_2_diff)]) ;
+                                               [(e_int 0, id_details_1) ;
-                             e_int 2;
+                                                (e_int 1, id_details_2_diff)])) ;
-                             e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let param = e_pair (e_int 1) (e_address owner_addr) in
+  let param = e_record_ez [("id", e_int 1) ;
-  let%bind () = expect_eq ~options program "update_owner"
+                           ("new_owner", e_address owner_addr)] in
+  let%bind () = expect_eq ~options (program, state) "update_owner"
       (e_pair param storage)
       (e_pair (e_list []) new_storage)
   in ok ()
 
 (* Test that contract fails when we attempt to update owner of nonexistent ID *)
 let update_owner_nonexistent () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -362,20 +392,23 @@ let update_owner_nonexistent () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let param = e_pair (e_int 2) (e_address new_addr) in
+  let param = e_record_ez [("id", e_int 2);
-  let%bind () = expect_string_failwith ~options program "update_owner"
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options (program, state) "update_owner"
       (e_pair param storage)
       "This ID does not exist."
   in ok ()
 
 (* Test that contract fails when we attempt to update owner from non-owner addr *)
 let update_owner_wrong_addr () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -393,19 +426,22 @@ let update_owner_wrong_addr () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let param = e_pair (e_int 0) (e_address new_addr) in
+  let param = e_record_ez [("id", e_int 0);
-  let%bind () = expect_string_failwith ~options program "update_owner"
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options (program, state) "update_owner"
       (e_pair param storage)
       "You are not the owner of this ID."
   in ok ()
 
 let skip () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -422,24 +458,28 @@ let skip () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let new_storage = e_record_ez [("identities", (e_big_map
-                                         (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                             e_int 3;
+                                                (e_int 1, id_details_2)])) ;
-                             e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 3) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let%bind () = expect_eq ~options program "skip"
+  let%bind () = expect_eq ~options (program, state) "skip"
       (e_pair (e_unit ()) storage)
       (e_pair (e_list []) new_storage)
   in ok ()
 
 (* Test that contract fails if we try to skip without paying the right amount *)
 let skip_wrong_amount () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let owner_addr = addr 5 in
   let owner_website = e_bytes_string "ligolang.org" in
   let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@@ -456,17 +496,19 @@ let skip_wrong_amount () =
                                   ("controller", e_address new_addr) ;
                                   ("profile", new_website)]
   in
-  let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ;
+  let storage = e_record_ez [("identities", (e_big_map
-                                     (e_int 1, id_details_2)]) ;
+                                               [(e_int 0, id_details_1) ;
-                         e_int 2;
+                                                (e_int 1, id_details_2)])) ;
-                         e_tuple [e_mutez 1000000 ; e_mutez 1000000]]
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
   in
-  let%bind () = expect_string_failwith ~options program "skip"
+  let%bind () = expect_string_failwith ~options (program, state) "skip"
       (e_pair (e_unit ()) storage)
       "Incorrect amount paid."
   in ok ()
 
-let main = test_suite "ID Layer" [
+let main = test_suite "ID Layer (CameLIGO)" [
     test "buy"    buy_id ;
     test "buy (sender addr)" buy_id_sender_addr ;
     test "buy (wrong amount)" buy_id_wrong_amount ;

src/test/id_tests_p.ml

@@ -0,0 +1,522 @@
+open Trace
+open Test_helpers
+open Ast_imperative
+
+
+let type_file f =
+  let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" (Contract "main") in
+  ok (typed,state)
+
+let get_program =
+  let s = ref None in
+  fun () -> match !s with
+    | Some s -> ok s
+    | None -> (
+        let%bind program = type_file "./contracts/id.ligo" in
+        s := Some program ;
+        ok program
+      )
+
+let compile_main () =
+  let%bind typed_prg,_     = get_program () in
+  let%bind mini_c_prg      = Ligo.Compile.Of_typed.compile typed_prg in
+  let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
+  let%bind (_contract: Tezos_utils.Michelson.michelson) =
+    (* fails if the given entry point is not a valid contract *)
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
+  ok ()
+
+let (first_owner , first_contract) =
+  let open Proto_alpha_utils.Memory_proto_alpha in
+  let id = List.nth dummy_environment.identities 0 in
+  let kt = id.implicit_contract in
+  Protocol.Alpha_context.Contract.to_b58check kt , kt
+
+let buy_id () =
+  let%bind program, state = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_some (e_address new_addr))) ;
+                          ] in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options (program, state) "buy" 
+      (e_pair param storage) 
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+let buy_id_sender_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_typed_none (t_address ())))] in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options program "buy"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails if we attempt to buy an ID for the wrong amount *)
+let buy_id_wrong_amount () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_some (e_address new_addr)))] in
+  let%bind () = expect_string_failwith ~options program "buy"
+      (e_pair param storage)
+      "Incorrect amount paid."
+  in ok ()
+
+let update_details_owner () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
+                                       ("controller", e_address new_addr) ;
+                                       ("profile", owner_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2_diff)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = owner_website in
+  let param = e_record_ez [("id", e_int 1) ;
+                       ("new_profile", e_some details) ;
+                       ("new_controller", e_some (e_address new_addr))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+let update_details_controller () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = owner_website in
+  let id_details_2 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
+                                       ("controller", e_address owner_addr) ;
+                                       ("profile", new_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2_diff)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails when we attempt to update details of nonexistent ID *)
+let update_details_nonexistent () = 
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 2) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_string_failwith ~options program "update_details"
+      (e_pair param storage)
+      "This ID does not exist."
+  in ok ()
+
+(* Test that contract fails when we attempt to update details from wrong addr *)
+let update_details_wrong_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 0) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_string_failwith ~options program "update_details"
+      (e_pair param storage)
+      "You are not the owner or controller of this ID."
+  in ok ()
+
+(* Test that giving none on both profile and controller address is a no-op *)
+let update_details_unchanged () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_profile", e_typed_none (t_bytes ())) ;
+                           ("new_controller", e_typed_none (t_address ()))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) storage)
+  in ok ()
+
+let update_owner () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
+                                       ("controller", e_address new_addr) ;
+                                       ("profile", new_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2_diff)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_owner", e_address owner_addr)] in
+  let%bind () = expect_eq ~options program "update_owner"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails when we attempt to update owner of nonexistent ID *)
+let update_owner_nonexistent () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 2);
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options program "update_owner"
+      (e_pair param storage)
+      "This ID does not exist."
+  in ok ()
+
+(* Test that contract fails when we attempt to update owner from non-owner addr *)
+let update_owner_wrong_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 0);
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options program "update_owner"
+      (e_pair param storage)
+      "You are not the owner of this ID."
+  in ok ()
+
+let skip () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 3) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options program "skip_"
+      (e_pair (e_unit ()) storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails if we try to skip without paying the right amount *)
+let skip_wrong_amount () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_string_failwith ~options program "skip_"
+      (e_pair (e_unit ()) storage)
+      "Incorrect amount paid."
+  in ok ()
+
+let main = test_suite "ID Layer (PascaLIGO)" [
+    test "buy"    buy_id ;
+    test "buy (sender addr)" buy_id_sender_addr ;
+    test "buy (wrong amount)" buy_id_wrong_amount ;
+    test "update_details (owner)" update_details_owner ;
+    test "update_details (controller)" update_details_controller ;
+    test "update_details_nonexistent" update_details_nonexistent ;
+    test "update_details_wrong_addr" update_details_wrong_addr ;
+    test "update_details_unchanged" update_details_unchanged ;
+    test "update_owner" update_owner ;
+    test "update_owner_nonexistent" update_owner_nonexistent ;
+    test "update_owner_wrong_addr" update_owner_wrong_addr ;
+    test "skip" skip ;
+    test "skip (wrong amount)" skip_wrong_amount ;
+]

src/test/id_tests_r.ml

@@ -0,0 +1,525 @@
+open Trace
+open Test_helpers
+open Ast_imperative
+
+
+let retype_file f =
+  let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" (Contract "main") in
+  ok (typed,state)
+
+let get_program =
+  let s = ref None in
+  fun () -> match !s with
+    | Some s -> ok s
+    | None -> (
+        let%bind program = retype_file "./contracts/id.religo" in
+        s := Some program ;
+        ok program
+      )
+
+let compile_main () =
+  let%bind typed_prg,_     = get_program () in
+  let%bind mini_c_prg      = Ligo.Compile.Of_typed.compile typed_prg in
+  let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
+  let%bind (_contract: Tezos_utils.Michelson.michelson) =
+    (* fails if the given entry point is not a valid contract *)
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
+  ok ()
+
+let (first_owner , first_contract) =
+  let open Proto_alpha_utils.Memory_proto_alpha in
+  let id = List.nth dummy_environment.identities 0 in
+  let kt = id.implicit_contract in
+  Protocol.Alpha_context.Contract.to_b58check kt , kt
+
+let buy_id () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_some (e_address new_addr))) ;
+                          ] in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options program "buy" 
+      (e_pair param storage) 
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+let buy_id_sender_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_typed_none (t_address ())))] in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options program "buy"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails if we attempt to buy an ID for the wrong amount *)
+let buy_id_wrong_amount () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
+                             ("next_id", e_int 1) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
+  in
+  let param = e_record_ez [("profile", owner_website) ;
+                           ("initial_controller", (e_some (e_address new_addr)))] in
+  let%bind () = expect_string_failwith ~options program "buy"
+      (e_pair param storage)
+      "Incorrect amount paid."
+  in ok ()
+
+let update_details_owner () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", new_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
+                                       ("controller", e_address new_addr) ;
+                                       ("profile", new_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2_diff)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 1) ;
+                       ("new_profile", e_some details) ;
+                       ("new_controller", e_some (e_address new_addr))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+let update_details_controller () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
+                                       ("controller", e_address owner_addr) ;
+                                       ("profile", new_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2_diff)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails when we attempt to update details of nonexistent ID *)
+let update_details_nonexistent () = 
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 2) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_string_failwith ~options program "update_details"
+      (e_pair param storage)
+      "This ID does not exist."
+  in ok ()
+
+(* Test that contract fails when we attempt to update details from wrong addr *)
+let update_details_wrong_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                                   [(e_int 0, id_details_1) ;
+                                                    (e_int 1, id_details_2)])) ;
+                                 ("next_id", e_int 2) ;
+                                 ("name_price", e_mutez 1000000) ;
+                                 ("skip_price", e_mutez 1000000) ; ]
+  in
+  let details = e_bytes_string "ligolang.org" in
+  let param = e_record_ez [("id", e_int 0) ;
+                           ("new_profile", e_some details) ;
+                           ("new_controller", e_some (e_address owner_addr))] in
+  let%bind () = expect_string_failwith ~options program "update_details"
+      (e_pair param storage)
+      "You are not the owner or controller of this ID."
+  in ok ()
+
+(* Test that giving none on both profile and controller address is a no-op *)
+let update_details_unchanged () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_profile", e_typed_none (t_bytes ())) ;
+                           ("new_controller", e_typed_none (t_address ()))] in
+  let%bind () = expect_eq ~options program "update_details"
+      (e_pair param storage)
+      (e_pair (e_list []) storage)
+  in ok ()
+
+let update_owner () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
+                                       ("controller", e_address new_addr) ;
+                                       ("profile", new_website)] in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2_diff)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 1) ;
+                           ("new_owner", e_address owner_addr)] in
+  let%bind () = expect_eq ~options program "update_owner"
+      (e_pair param storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails when we attempt to update owner of nonexistent ID *)
+let update_owner_nonexistent () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 2);
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options program "update_owner"
+      (e_pair param storage)
+      "This ID does not exist."
+  in ok ()
+
+(* Test that contract fails when we attempt to update owner from non-owner addr *)
+let update_owner_wrong_addr () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero)
+      ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let param = e_record_ez [("id", e_int 0);
+                           ("new_owner", e_address new_addr)] in
+  let%bind () = expect_string_failwith ~options program "update_owner"
+      (e_pair param storage)
+      "You are not the owner of this ID."
+  in ok ()
+
+let skip () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let new_storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 3) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_eq ~options program "skip"
+      (e_pair (e_unit ()) storage)
+      (e_pair (e_list []) new_storage)
+  in ok ()
+
+(* Test that contract fails if we try to skip without paying the right amount *)
+let skip_wrong_amount () =
+  let%bind program = get_program () in
+  let owner_addr = addr 5 in
+  let owner_website = e_bytes_string "ligolang.org" in
+  let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
+                                  ("controller", e_address owner_addr) ;
+                                  ("profile", owner_website)]
+  in
+  let new_addr = first_owner in
+  let options = Proto_alpha_utils.Memory_proto_alpha.make_options
+      ~sender:first_contract
+      ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
+  in
+  let new_website = e_bytes_string "ligolang.org" in
+  let id_details_2 = e_record_ez [("owner", e_address new_addr) ;
+                                  ("controller", e_address new_addr) ;
+                                  ("profile", new_website)]
+  in
+  let storage = e_record_ez [("identities", (e_big_map
+                                               [(e_int 0, id_details_1) ;
+                                                (e_int 1, id_details_2)])) ;
+                             ("next_id", e_int 2) ;
+                             ("name_price", e_mutez 1000000) ;
+                             ("skip_price", e_mutez 1000000) ; ]
+  in
+  let%bind () = expect_string_failwith ~options program "skip"
+      (e_pair (e_unit ()) storage)
+      "Incorrect amount paid."
+  in ok ()
+
+let main = test_suite "ID Layer (ReasonLIGO)" [
+    test "buy"    buy_id ;
+    test "buy (sender addr)" buy_id_sender_addr ;
+    test "buy (wrong amount)" buy_id_wrong_amount ;
+    test "update_details (owner)" update_details_owner ;
+    test "update_details (controller)" update_details_controller ;
+    test "update_details_nonexistent" update_details_nonexistent ;
+    test "update_details_wrong_addr" update_details_wrong_addr ;
+    test "update_details_unchanged" update_details_unchanged ;
+    test "update_owner" update_owner ;
+    test "update_owner_nonexistent" update_owner_nonexistent ;
+    test "update_owner_wrong_addr" update_owner_wrong_addr ;
+    test "skip" skip ;
+    test "skip (wrong amount)" skip_wrong_amount ;
+]

src/test/integration_tests.ml

@@ -4,17 +4,11 @@ open Test_helpers
 open Ast_imperative.Combinators
 
 let retype_file f =
-  let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" Env in
+  Ligo.Compile.Utils.type_file f "reasonligo" Env
-  let () = Typer.Solver.discard_state state in
-  ok typed
 let mtype_file f =
-  let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" Env in
+  Ligo.Compile.Utils.type_file f "cameligo" Env
-  let () = Typer.Solver.discard_state state in
-  ok typed
 let type_file f =
-  let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" Env in
+  Ligo.Compile.Utils.type_file f "pascaligo" Env
-  let () = Typer.Solver.discard_state state in
-  ok typed
 
 let type_alias () : unit result =
   let%bind program = type_file "./contracts/type-alias.ligo" in

src/test/multisig_tests.ml

@@ -76,39 +76,39 @@ let params counter msg keys is_validl f s =
 
 (* Provide one valid signature when the threshold is two of two keys *)
 let not_enough_1_of_2 f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let exp_failwith = "Not enough signatures passed the check" in
   let keys = gen_keys () in
   let%bind test_params = params 0 empty_message [keys] [true] f s in
   let%bind () = expect_string_failwith
-    program "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in
+    (program, state) "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in
   ok ()
 
 let unmatching_counter f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let exp_failwith = "Counters does not match" in
   let keys = gen_keys () in
   let%bind test_params = params 1 empty_message [keys] [true] f s in
   let%bind () = expect_string_failwith
-    program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in
+    (program, state) "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in
   ok ()
 
 (* Provide one invalid signature (correct key but incorrect signature)
    when the threshold is one of one key *)
 let invalid_1_of_1 f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let exp_failwith = "Invalid signature" in
   let keys = [gen_keys ()] in
   let%bind test_params = params 0 empty_message keys [false] f s in
   let%bind () = expect_string_failwith
-    program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in
+    (program, state) "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in
   ok ()
 
 (* Provide one valid signature when the threshold is one of one key *)
 let valid_1_of_1 f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let keys = gen_keys () in
-  let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
+  let%bind () = expect_eq_n_trace_aux [0;1;2] (program, state) "main"
       (fun n ->
         let%bind params = params n empty_message [keys] [true] f s in
         ok @@ e_pair params (init_storage 1 n [keys])
@@ -120,10 +120,10 @@ let valid_1_of_1 f s () =
 
 (* Provive two valid signatures when the threshold is two of three keys *)
 let valid_2_of_3 f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let param_keys = [gen_keys (); gen_keys ()] in
   let st_keys = param_keys @ [gen_keys ()] in
-  let%bind () = expect_eq_n_trace_aux [0;1;2] program "main"
+  let%bind () = expect_eq_n_trace_aux [0;1;2] (program, state) "main"
       (fun n ->
         let%bind params = params n empty_message param_keys [true;true] f s in
         ok @@ e_pair params (init_storage 2 n st_keys)
@@ -135,7 +135,7 @@ let valid_2_of_3 f s () =
 
 (* Provide one invalid signature and two valid signatures when the threshold is two of three keys *)
 let invalid_3_of_3 f s () =
-  let%bind program,_ = get_program f s () in
+  let%bind (program , state) = get_program f s () in
   let valid_keys = [gen_keys() ; gen_keys()] in
   let invalid_key = gen_keys () in
   let param_keys = valid_keys @ [invalid_key] in
@@ -143,18 +143,18 @@ let invalid_3_of_3 f s () =
   let%bind test_params = params 0 empty_message param_keys [false;true;true] f s in
   let exp_failwith = "Invalid signature" in
   let%bind () = expect_string_failwith
-    program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in
+    (program, state) "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in
   ok ()
 
 (* Provide two valid signatures when the threshold is three of three keys *)
 let not_enough_2_of_3 f s () =
-  let%bind program,_ = get_program f s() in
+  let%bind (program , state) = get_program f s() in
   let valid_keys = [gen_keys() ; gen_keys()] in
   let st_keys = gen_keys () :: valid_keys  in
   let%bind test_params = params 0 empty_message (valid_keys) [true;true] f s in
   let exp_failwith = "Not enough signatures passed the check" in
   let%bind () = expect_string_failwith
-    program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in
+    (program, state) "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in
   ok ()
 
 let main = test_suite "Multisig" [

src/test/multisig_v2_tests.ml

@@ -65,7 +65,7 @@ let storage {state_hash ; threshold ; max_proposal ; max_msg_size ; id_counter_l
 
 (* sender not stored in the authorized set *)
 let wrong_addr () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let init_storage = storage {
     threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ;
     id_counter_list = [1,0 ; 2,0] ;
@@ -75,13 +75,13 @@ let wrong_addr () =
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
   let%bind () =
     let exp_failwith = "Unauthorized address" in
-    expect_string_failwith ~options program "main"
+    expect_string_failwith ~options (program, state) "main"
     (e_pair (send_param empty_message) init_storage) exp_failwith in
   ok ()
 
 (* send a message which exceed the size limit *)
 let message_size_exceeded () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let init_storage = storage {
     threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ;
     id_counter_list = [1,0] ;
@@ -91,13 +91,13 @@ let message_size_exceeded () =
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
   let%bind () =
     let exp_failwith = "Message size exceed maximum limit" in
-    expect_string_failwith ~options program "main"
+    expect_string_failwith ~options (program, state) "main"
     (e_pair (send_param empty_message)  init_storage) exp_failwith in
   ok ()
 
 (* sender has already has reached maximum number of proposal *)
 let maximum_number_of_proposal () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload1 = pack_payload program (send_param empty_message) in
   let bytes1 = e_bytes_raw packed_payload1 in
   let init_storage = storage {
@@ -109,13 +109,13 @@ let maximum_number_of_proposal () =
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
   let%bind () =
     let exp_failwith = "Maximum number of proposal reached" in
-    expect_string_failwith ~options program "main"
+    expect_string_failwith ~options (program, state) "main"
       (e_pair (send_param empty_message2) init_storage) exp_failwith in
   ok ()
 
 (* sender message is already stored in the message store *)
 let send_already_accounted () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let init_storage = storage {
@@ -126,12 +126,12 @@ let send_already_accounted () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair (send_param empty_message) init_storage) (e_pair empty_op_list init_storage)
 
 (* sender message isn't stored in the message store *)
 let send_never_accounted () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let init_storage' = {
@@ -147,12 +147,12 @@ let send_never_accounted () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair (send_param empty_message) init_storage) (e_pair empty_op_list final_storage)
 
 (* sender withdraw message is already binded to one address in the message store *)
 let withdraw_already_accounted_one () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let param = withdraw_param in
@@ -168,12 +168,12 @@ let withdraw_already_accounted_one () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair param init_storage) (e_pair empty_op_list final_storage)
 
 (* sender withdraw message is already binded to two addresses in the message store *)
 let withdraw_already_accounted_two () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let param = withdraw_param in
@@ -189,12 +189,12 @@ let withdraw_already_accounted_two () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair param init_storage) (e_pair empty_op_list final_storage)
 
 (* triggers the threshold and check that all the participants get their counters decremented *)
 let counters_reset () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let param = send_param empty_message in
@@ -212,12 +212,12 @@ let counters_reset () =
   let options =
     let sender = contract 3 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair param init_storage) (e_pair empty_op_list final_storage)
 
 (* sender withdraw message was never accounted *)
 let withdraw_never_accounted () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let param = withdraw_param in
   let init_storage = storage {
     threshold = 2 ; max_proposal = 1 ;  max_msg_size = 1 ; state_hash = Bytes.empty ;
@@ -227,12 +227,12 @@ let withdraw_never_accounted () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  expect_eq ~options program "main"
+  expect_eq ~options (program, state) "main"
     (e_pair param init_storage) (e_pair empty_op_list init_storage)
 
 (* successful storing in the message store *)
 let succeeded_storing () =
-  let%bind program,_ = get_program () in
+  let%bind (program , state) = get_program () in
   let%bind packed_payload = pack_payload program empty_message in
   let bytes = e_bytes_raw packed_payload in
   let init_storage th = {
@@ -243,7 +243,7 @@ let succeeded_storing () =
   let options =
     let sender = contract 1 in
     Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
-  let%bind () = expect_eq_n_trace_aux ~options [1;2] program "main"
+  let%bind () = expect_eq_n_trace_aux ~options [1;2] (program, state) "main"
       (fun th ->
         let init_storage = storage (init_storage th) in
         ok @@ e_pair (send_param empty_message) init_storage

src/test/pledge_tests.ml

@@ -45,36 +45,36 @@ let empty_message = e_lambda (Var.of_name "arguments")
 
 
 let pledge () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let storage = e_address oracle_addr in
   let parameter = e_unit () in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
                   ~sender:oracle_contract
                   ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
   in
-  expect_eq ~options program "donate"
+  expect_eq ~options (program, state) "donate"
     (e_pair parameter storage)
     (e_pair (e_list []) storage)
 
 let distribute () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let storage = e_address oracle_addr in
   let parameter =  empty_message in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
                   ~sender:oracle_contract ()
   in
-  expect_eq ~options program "distribute"
+  expect_eq ~options (program, state) "distribute"
     (e_pair parameter storage)
     (e_pair (e_list []) storage)
 
 let distribute_unauthorized () =
-  let%bind program, _ = get_program () in
+  let%bind (program , state) = get_program () in
   let storage = e_address oracle_addr in
   let parameter =  empty_message in
   let options = Proto_alpha_utils.Memory_proto_alpha.make_options
                   ~sender:stranger_contract ()
   in
-  expect_string_failwith ~options program "distribute"
+  expect_string_failwith ~options (program, state) "distribute"
     (e_pair parameter storage)
     "You're not the oracle for this distribution."