nix/changelog.nix

 { runCommand, writeTextFile, buildEnv, jq, yaml2json, git, mustache-go }:
 let
-  json = runCommand "changelog.json" { buildInputs = [ git jq yaml2json ]; } ''
-    cp -r ${builtins.path { name = "git"; path = ../.git; }} .git
-    cp -r ${../changelog} changelog
-    cp -r ${../scripts} scripts
-    bash ./scripts/changelog-json.sh > $out
-  '';
+  json = if builtins.elem ".git" (builtins.attrNames (builtins.readDir ../.)) then
+    runCommand "changelog.json" { buildInputs = [ git jq yaml2json ]; } ''
+      cp -r ${builtins.path { name = "git"; path = ../.git; }} .git
+      cp -r ${../changelog} changelog
+      cp -r ${../scripts} scripts
+      bash ./scripts/changelog-json.sh > $out
+    '' else builtins.toFile "changelog.json" (builtins.toJSON { changelog = [ { version = "Unknown; This executable was built without .git"; } ]; });
 
   changelog = {
     text = runCommand "changelog-text" { buildInputs = [ mustache-go ]; }

nix/ocaml-overlay.nix

@@ -86,10 +86,11 @@ in {
               Rolling release
               Commit SHA: ${CI_COMMIT_SHA}
               Commit Date: ${COMMIT_DATE}
-            '' else ''
-              Rolling release
-              Commit SHA: ${self.lib.commitIdFromGitRepo ../.git}
-            '')
+            '' else
+              if builtins.elem ".git" (builtins.attrNames (builtins.readDir ../.)) then ''
+                Rolling release
+                Commit SHA: ${self.lib.commitIdFromGitRepo ../.git}
+              '' else "Unknown: not built from a git checkout")
           else
             "${CI_COMMIT_TAG}";
           inherit CI_COMMIT_TAG CI_COMMIT_SHA COMMIT_DATE;

src/bin/expect_tests/contract_tests.ml

@@ -1403,8 +1403,8 @@ let%expect_test _ =
      let p2 = (f2)@(s) in { ASSERTION(p2);
      s}}}
     const letin_nesting2 = lambda (x:Some(int)) : None return let y = 2 in let z = 3 in ADD(ADD(x ,
-    y) ,
-    z)
+    y) , z) const x = let #5 = (+1 , (+2 ,
+    +3)) in let #4 = #5.0 in let #3 = #5.1 in let x = #3.0 in let #2 = #3.1 in x
     |}];
 
   run_ligo_good ["print-ast"; contract "letin.religo"];
@@ -1427,8 +1427,8 @@ let%expect_test _ =
      let p2 = (f2)@(s) in { ASSERTION(p2);
      s}}}
     const letin_nesting2 = lambda (x:Some(int)) : None return let y = 2 in let z = 3 in ADD(ADD(x ,
-    y) ,
-    z)
+    y) , z) const x = let #4 = (+1 , (+2 ,
+    +3)) in let #3 = #4.0 in let #2 = #4.1 in let x = #2.0 in let #1 = #2.1 in x
     |}];
 
   run_ligo_bad ["print-ast-typed"; contract "existential.mligo"];

src/passes/01-parsing/reasonligo/Parser.mly

@@ -627,12 +627,15 @@ disj_expr_level:
 | par(tuple(disj_expr_level)) type_annotation_simple? {
     let region = nsepseq_to_region expr_to_region $1.value.inside in
     let tuple  = ETuple {value=$1.value.inside; region} in
+    let par = 
+      EPar {$1 with value = {$1.value with inside = tuple}} in
     match $2 with
       Some (colon, typ) ->
         let region = cover $1.region (type_expr_to_region typ)
-        and value = {$1.value with inside = tuple,colon,typ}
+        and value = {$1.value with inside = par,colon,typ}
         in EAnnot {region; value}
-    | None -> tuple }
+    | None -> par
+    }
 
 bin_op(arg1,op,arg2):
   arg1 op arg2 {

src/passes/01-parsing/reasonligo/Pretty.ml

@@ -118,8 +118,8 @@ and pp_ptuple {value; _} =
   | p::items ->
       group (break 1 ^^ pp_pattern p ^^ string ",") ^^ app items
   in if tail = []
-     then string "(" ^^ nest 1 (pp_pattern head) ^^ string ")"
-     else string "(" ^^ nest 1 (pp_pattern head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
+     then nest 1 (pp_pattern head)
+     else nest 1 (pp_pattern head ^^ string "," ^^ app (List.map snd tail))
 
 and pp_precord fields = pp_ne_injection pp_field_pattern fields
 
@@ -344,8 +344,8 @@ and pp_tuple_expr {value; _} =
   | e::items ->
       group (break 1 ^^ pp_expr e ^^ string ",") ^^ app items
   in if tail = []
-     then string "(" ^^ nest 1 (pp_expr head) ^^ string ")"
-     else string "(" ^^ nest 1 (pp_expr head ^^ string "," ^^ app (List.map snd tail)) ^^ string ")"
+     then nest 1 (pp_expr head)
+     else nest 1 (pp_expr head ^^ string "," ^^ app (List.map snd tail))
 
 and pp_par_expr {value; _} =
   string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")

src/passes/03-tree_abstraction/cameligo/compiler.ml

@@ -297,12 +297,14 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
         [] -> body,lhs_type
       | ((args,ty_opt),exprs):: lst ->
         let expr,lhs_type = aux lst in
-        let expr = List.fold_left (|>) expr exprs in
+        let aux expr (binder, ty_opt ,attr,rhs) = e_let_in (binder,ty_opt) attr rhs expr in
+        let expr = List.fold_left aux expr exprs in
         e_lambda ~loc args ty_opt lhs_type expr,
         Option.map (Utils.uncurry @@ t_function ~loc) @@ Option.bind_pair (ty_opt,lhs_type)
     in
     let expr,lhs_type = aux lst in
-    let expr = List.fold_right (@@) exprs expr  in
+    let aux (binder, ty_opt,attr,rhs) expr = e_let_in (binder, ty_opt) attr rhs expr in
+    let expr = List.fold_right aux exprs expr  in
     return @@ e_lambda ~loc binder ty_opt lhs_type expr 
   | EConstr (ESomeApp some) ->
     let ((_, arg), loc) = r_split some in
@@ -449,7 +451,7 @@ fun cases ->
   | _ -> fail @@ unsupported_pattern_type @@ List.map fst @@ List.Ne.to_list cases
 
 and compile_let_binding ?kwd_rec attributes binding =
-  let return = ok in
+  let return lst = ok lst in
   let return_1 a = return [a] in
   let ({binders; lhs_type; let_rhs; _} : CST.let_binding) = binding in
   let attr = compile_attribute_declaration attributes in
@@ -468,7 +470,8 @@ and compile_let_binding ?kwd_rec attributes binding =
       | ((args,ty_opt),exprs):: lst ->
         let loc = Location.get_location args in
         let expr,lhs_type = aux lst in
-        let expr = List.fold_left (|>) expr exprs in
+        let aux expr (binder, ty_opt ,attr,rhs) = e_let_in (binder,ty_opt) attr rhs expr in
+        let expr = List.fold_left aux expr exprs in
         e_lambda ~loc args ty_opt lhs_type expr,
         Option.map (Utils.uncurry @@ t_function ~loc) @@ Option.bind_pair (ty_opt,lhs_type)
     in
@@ -486,11 +489,12 @@ and compile_let_binding ?kwd_rec attributes binding =
   | PTuple tuple, [] -> (* Tuple destructuring *)
     let (tuple, loc) = r_split tuple in
     let%bind lst = bind_map_ne_list compile_parameter @@ npseq_to_ne_list tuple in
-    let (lst, _) = List.Ne.split lst in
+    let (lst, exprs) = List.Ne.split lst in
+    let exprs = List.flatten @@ List.Ne.to_list exprs in
     let var = Location.wrap ~loc @@ Var.fresh () in
     let body = e_variable var in
-    let aux i (var, ty_opt) = Z.add i Z.one, (var,ty_opt, attr, e_accessor body @@ [Access_tuple i]) in
-    return @@ (var,None, false, expr) :: (List.fold_map aux Z.zero @@ List.Ne.to_list lst)
+    let aux i (var', ty_opt) = Z.add i Z.one, (var',ty_opt, attr, e_accessor body @@ [Access_tuple i]) in
+    return @@ (var,None, false, expr) :: (List.fold_map aux Z.zero @@ List.Ne.to_list lst) @ exprs
   | _ -> fail @@ unsupported_pattern_type @@ nseq_to_list binders
   in aux binders
 
@@ -523,7 +527,8 @@ and compile_parameter : CST.pattern -> _ result = fun pattern ->
       Location.unwrap var, []
     | var, lst ->
       let binder = Var.fresh () in
-      binder, [e_matching_tuple ~loc (e_variable @@ Location.wrap ~loc binder) (var::lst) None ]
+      let aux i var = Z.add i Z.one, (var,None, false, e_accessor (e_variable @@ Location.wrap ~loc binder) @@ [Access_tuple i]) in
+      binder, List.fold_map aux Z.zero @@ var :: lst
     in
     let exprs = List.flatten @@ expr :: List.Ne.to_list exprs in
     return ?ty loc exprs @@ var 

src/passes/03-tree_abstraction/cameligo/errors.ml

@@ -60,47 +60,47 @@ let rec error_ppformat : display_format:string display_format ->
     match a with
     | `Concrete_cameligo_wrong_pattern (expected_name,actual) ->
       Format.fprintf f
-        "@[<hv>%a@Wrong pattern: expected %s got %s@]"
+        "@[<hv>%a@ Wrong pattern: expected %s got %s@]"
         Location.pp_lift (Raw.pattern_to_region actual)
         (Cst_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point actual)
         expected_name
     | `Concrete_cameligo_unsupported_let_in expr ->
       Format.fprintf f
-        "@[<hv>%a@Defining functions with \"let ... in\" is not supported yet@]"
+        "@[<hv>%a@ Defining functions with \"let ... in\" is not supported yet@]"
         Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost expr)
     | `Concrete_cameligo_unknown_predefined_type type_name ->
       Format.fprintf f
-        "@[<hv>%a@Unknown predefined type \"%s\"@]"
+        "@[<hv>%a@ Unknown predefined type \"%s\"@]"
         Location.pp_lift type_name.Region.region
         type_name.Region.value
     | `Concrete_cameligo_untyped_fun_param variable ->
       Format.fprintf f
-        "@[<hv>%a@Untyped function parameters are not supported yet@]"
+        "@[<hv>%a@ Untyped function parameters are not supported yet@]"
         Location.pp_lift variable.Region.region
     | `Concrete_cameligo_recursive_fun reg ->
       Format.fprintf f
-        "@[<hv>%a@Untyped recursive functions are not supported yet@]"
+        "@[<hv>%a@ Untyped recursive functions are not supported yet@]"
         Location.pp_lift reg
     | `Concrete_cameligo_unsupported_tuple_pattern p ->
       Format.fprintf f
-        "@[<hv>%a@The following tuple pattern is not supported yet:@\"%s\"@]"
+        "@[<hv>%a@ The following tuple pattern is not supported yet:@\"%s\"@]"
         Location.pp_lift (Raw.pattern_to_region p)
         (Cst_cameligo.ParserLog.pattern_to_string ~offsets:true ~mode:`Point p)
     | `Concrete_cameligo_unsupported_constant_constr p ->
       Format.fprintf f
-        "@[<hv>%a@Constant constructors are not supported yet@]"
+        "@[<hv>%a@ Constant constructors are not supported yet@]"
         Location.pp_lift (Raw.pattern_to_region p)
     | `Concrete_cameligo_unsupported_non_var_pattern p ->
       Format.fprintf f
-        "@[<hv>%a@Non-variable patterns in constructors are not supported yet@]"
+        "@[<hv>%a@ Non-variable patterns in constructors are not supported yet@]"
         Location.pp_lift (Raw.pattern_to_region p)
     | `Concrete_cameligo_unsupported_pattern_type pl ->
       Format.fprintf f
-        "@[<hv>%a@Currently, only booleans, lists, options, and constructors are supported in patterns@]"
+        "@[<hv>%a@ Currently, only booleans, lists, options, and constructors are supported in patterns@]"
         Location.pp_lift (List.fold_left (fun a p -> Region.cover a (Raw.pattern_to_region p)) Region.ghost pl)
     | `Concrete_cameligo_unsupported_string_singleton te ->
       Format.fprintf f
-        "@[<hv>%a@Unsupported singleton string type@]"
+        "@[<hv>%a@ Unsupported singleton string type@]"
         Location.pp_lift (Raw.type_expr_to_region te)
     | `Concrete_cameligo_unsupported_deep_list_pattern cons ->
       Format.fprintf f
@@ -112,28 +112,28 @@ let rec error_ppformat : display_format:string display_format ->
         Location.pp_lift @@ tuple.Region.region
     | `Concrete_cameligo_abstraction_tracer (expr,err) ->
       Format.fprintf f
-        "@[<hv>%a@Abstracting expression:@\"%s\"@%a@]"
+        "@[<hv>%a@ Abstracting expression:@\"%s\"@%a@]"
         Location.pp_lift (Raw.expr_to_region expr)
         (Cst_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
         (error_ppformat ~display_format) err
     | `Concrete_cameligo_abstraction_type_tracer (te,err) ->
       Format.fprintf f
-        "@[<hv>%a@Abstracting type expression:@\"%s\"@%a@]"
+        "@[<hv>%a@ Abstracting type expression:@\"%s\"@%a@]"
         Location.pp_lift (Raw.type_expr_to_region te)
         (Cst_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point te)
         (error_ppformat ~display_format) err
     | `Concrete_cameligo_bad_deconstruction expr ->
       Format.fprintf f
-        "@[<hv>%a@Bad tuple deconstruction \"%s\"@]"
+        "@[<hv>%a@ Bad tuple deconstruction \"%s\"@]"
         Location.pp_lift (Raw.expr_to_region expr)
         (Cst_cameligo.ParserLog.expr_to_string ~offsets:true ~mode:`Point expr)
     | `Concrete_cameligo_only_constructors p ->
       Format.fprintf f
-        "@[<hv>%a@Currently, only constructors are supported in patterns@]"
+        "@[<hv>%a@ Currently, only constructors are supported in patterns@]"
         Location.pp_lift (Raw.pattern_to_region p)
     | `Concrete_cameligo_unsupported_sugared_lists wild ->
       Format.fprintf f
-        "@[<hv>%a@Currently, only empty lists and constructors (::) are supported in patterns@]"
+        "@[<hv>%a@ Currently, only empty lists and constructors (::) are supported in patterns@]"
         Location.pp_lift wild
     | `Concrete_cameligo_corner_case desc ->
       Format.fprintf f "Corner case: %s" desc
@@ -141,18 +141,18 @@ let rec error_ppformat : display_format:string display_format ->
       Format.fprintf f "Unknown built-in function %s" bi
     | `Concrete_cameligo_michelson_type_wrong (texpr,name) ->
       Format.fprintf f
-        "@[<hv>%a@Argument %s of %s must be a string singleton@]"
+        "@[<hv>%a@ Argument %s of %s must be a string singleton@]"
           Location.pp_lift (Raw.type_expr_to_region texpr)
           (Cst_cameligo.ParserLog.type_expr_to_string ~offsets:true ~mode:`Point texpr)
           name
     | `Concrete_cameligo_michelson_type_wrong_arity (loc,name) ->
       Format.fprintf f
-        "@[<hv>%a@%s does not have the right number of argument@]"
+        "@[<hv>%a@ %s does not have the right number of argument@]"
         Location.pp loc
         name
     | `Concrete_cameligo_program_tracer (decl,err) ->
       Format.fprintf f
-        "@[<hv>%a@Abstracting program@%a@]"
+        "@[<hv>%a@ Abstracting program@%a@]"
         Location.pp_lift (List.fold_left (fun a d -> Region.cover a (Raw.declaration_to_region d)) Region.ghost decl)
         (error_ppformat ~display_format) err
   )

src/passes/03-tree_abstraction/reasonligo/compiler.ml

@@ -292,7 +292,8 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
     let%bind lhs_type = bind_map_option (compile_type_expression <@ snd) lhs_type in
     let%bind ((binder,ty_opt),exprs) = compile_parameter binders in
     let%bind body = compile_expression body in
-    let expr = List.fold_right (@@) exprs body  in
+    let aux (binder, ty_opt,attr,rhs) expr = e_let_in (binder, ty_opt) attr rhs expr in
+    let expr = List.fold_right aux exprs body  in
     return @@ e_lambda ~loc binder ty_opt lhs_type expr 
   | EConstr (ESomeApp some) ->
     let ((_, arg), loc) = r_split some in
@@ -439,7 +440,7 @@ fun cases ->
   | _ -> fail @@ unsupported_pattern_type @@ List.hd @@ List.map fst @@ List.Ne.to_list cases
 
 and compile_let_binding ?kwd_rec attributes binding =
-  let return = ok in
+  let return lst = ok lst in
   let return_1 a = return [a] in
   let ({binders; lhs_type; let_rhs; _} : CST.let_binding) = binding in
   let attr = compile_attribute_declaration attributes in
@@ -465,11 +466,12 @@ and compile_let_binding ?kwd_rec attributes binding =
   | PTuple tuple -> (* Tuple destructuring *)
     let (tuple, loc) = r_split tuple in
     let%bind lst = bind_map_ne_list compile_parameter @@ npseq_to_ne_list tuple in
-    let (lst, _) = List.Ne.split lst in
+    let (lst, exprs) = List.Ne.split lst in
+    let exprs = List.flatten @@ List.Ne.to_list exprs in
     let var = Location.wrap ~loc @@ Var.fresh () in
     let body = e_variable var in
     let aux i (var, ty_opt) = Z.add i Z.one, (var,ty_opt, attr, e_accessor body @@ [Access_tuple i]) in
-    return @@ (var,None, false, expr) :: (List.fold_map aux Z.zero @@ List.Ne.to_list lst)
+    return @@ (var,None, false, expr) :: (List.fold_map aux Z.zero @@ List.Ne.to_list lst) @ exprs
   | _ -> fail @@ unsupported_pattern_type @@ binders
   in aux binders
 
@@ -502,7 +504,8 @@ and compile_parameter : CST.pattern -> _ result = fun pattern ->
       Location.unwrap var, []
     | var, lst ->
       let binder = Var.fresh () in
-      binder, [e_matching_tuple ~loc (e_variable @@ Location.wrap ~loc binder) (var::lst) None ]
+      let aux i var = Z.add i Z.one, (var,None, false, e_accessor (e_variable @@ Location.wrap ~loc binder) @@ [Access_tuple i]) in
+      binder, List.fold_map aux Z.zero @@ var :: lst
     in
     let exprs = List.flatten @@ expr :: List.Ne.to_list exprs in
     return ?ty loc exprs @@ var 

src/stages/4-ast_core/dune

 (rule
-  (targets generated_fold.ml generated_map.ml generated_o.ml)
-  (deps ../adt_generator/generator.raku ast.ml ../common/enums.ml)
-  (action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml core))
+  (targets generated_fold.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/fold.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/fold.raku ast.ml generated_fold.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_o.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/combinators.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/combinators.raku ast.ml generated_o.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_map.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/fold_map.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/fold_map.raku ast.ml Generated_o generated_map.ml))
   (mode (promote (until-clean) (only *)))
 )
 

src/stages/5-ast_typed/dune

 (rule
-  (targets generated_fold.ml generated_map.ml generated_o.ml)
-  ;; TODO: auto-generate the dependencies on the files "(*@ follow *)"-ed by the generator
-  (deps ../adt_generator/generator.raku ast.ml ../common/enums.ml)
-  (action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml typed))
+  (targets generated_fold.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/fold.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/fold.raku ast.ml generated_fold.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_o.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/combinators.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/combinators.raku ast.ml generated_o.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_map.ml)
+  (deps ../adt_generator/Parser.pm ../adt_generator/fold_map.raku ast.ml ../common/enums.ml)
+  (action (run perl6 -I ../adt_generator/ ../adt_generator/fold_map.raku ast.ml Generated_o generated_map.ml))
   (mode (promote (until-clean) (only *)))
 )
 

src/stages/5-ast_typed/types_utils.ml

@@ -37,7 +37,10 @@ let fold_map__list : type a state new_a err . (state -> a -> (state * new_a , er
     let%bind state , l = acc in
     let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
   let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
-  ok (state , l)
+  (* fold_left with a list accumulator will produce the results in
+     reverse order, so we apply List.rev to put them back in the right
+     order. *)
+  ok (state , List.rev l)
 
 let fold_map__location_wrap : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a location_wrap -> (state * new_a location_wrap , err) result =
   fun f state { wrap_content ; location } ->
@@ -52,7 +55,10 @@ let fold_map__list_ne : type a state new_a err . (state -> a -> (state * new_a ,
     let%bind (state , new_element) = f state element in
     ok (state , new_element :: l) in
   let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
-  ok (state , (new_first , l))
+  (* fold_left with a list accumulator will produce the results in
+     reverse order, so we apply List.rev to put them back in the right
+     order. *)
+  ok (state , (new_first , List.rev l))
 
 let fold_map__option : type a state new_a err . (state -> a -> (state * new_a , err) result) -> state -> a option -> (state * new_a option , err) result =
   fun f state o ->

src/stages/adt_generator/.gitignore

 # This is an auto-generated test file
 /generated_fold.ml
+/.precomp

src/stages/adt_generator/Parser.pm

+#!/usr/bin/env perl6
+use v6.c;
+use strict;
+use worries;
+
+unit module Parser;
+sub parse ($inputADTfile) is export {
+    my $moduleName = $inputADTfile.subst(/\.ml$/, '').samecase("A_");
+    my $variant = "_ _variant";
+    my $record = "_ _ record";
+    sub poly { $^type_name }
+
+    my $l = $inputADTfile.IO.lines;
+    # TODO: do the inlining recursively?
+    $l = $l.map({
+        given $_ {
+            when /^(\(\*\s+)?(open|include) \s+ (<-blank -[\(]>*) \s* \(\*\@ \s* follow \s* (<-blank -[\*]>*) \s* \*\)\s*$/ {
+                flat ["(* $/[2] followed from $/[3] *)"],
+                     $/[3].IO.lines.list,
+                     ["(* end of $/[2] followed from $/[3] *)"]
+            }
+            default { [$_] }
+        }
+    }).flat;
+    $l = $l.grep(none /^\(\*\@ \s* ignore \s* \*\)/);
+    $l = $l.map(*.subst: /(^\s+|\s+$)/, "", :g);
+    $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.
+    $l = $l.join("\n").subst(/\n+/, "\n", :g); # join lines and remove consecutive newlines
+    $l = $l.subst(/\s*\(\* ( <-[\*]> | \*+<-[\*\)]> )* \*\)/, '', :g); # discard comments (incl. multi-line comments)
+    $l = $l.split(/\nand\s+/).grep(/./); # split lines again and preserve nonempty lines
+    $l = $l.map(*.split("\n"));
+    $l = $l.map: {
+    my $ll = $_;
+    my ($name, $kind) = do given $_[0] {
+        when /^((\w|\')+)\s*\=$/   { "$/[0]", $variant }
+        when /^((\w|\')+)\s*\=\s*\{$/ { "$/[0]", $record }
+        when /^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ { "$/[0]", poly("$/[2]") }
+        default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
+    };
+    my $ctorsOrFields = do {
+        when (/^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
+        default {
+            $_[1..*].grep({ ! /^\}?$/ }).map: {
+                when /^\|\s*((\w|\')+)\s*of\s+((\w|\')+)$/ { "$/[0]", "$/[1]" }
+                when /^\|\s*((\w|\')+)$/ { "$/[0]", "" }
+                when /^((\w|\')+)\s*\:\s*((\w|\')+)\s*\;$/ { "$/[0]", "$/[1]" }
+                default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
+            }
+        };
+    }
+    %{
+        "name"          => $name ,
+        "kind"          => $kind ,
+        "ctorsOrFields" => $ctorsOrFields
+    }
+    };
+
+    my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
+    {
+    "name"          => $name ,
+    "oNewName"      => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}",
+    "newName"       => $name ,
+    "kind"          => $kind ,
+    "ctorsOrFields" => @(map -> ($cf, $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 ,
+        oNewName  => "O.{$cf}" ,
+        newName   => $cf ,
+        isBuiltin => $isBuiltin ,
+        type      => $type ,
+        oNewType  => $isBuiltin ?? "$type" !! "O.{$type}" ,
+        newType   => $type ,
+    }
+    }, @ctorsOrFields),
+    }
+    }, @$l.cache).list;
+
+    ($adts, $moduleName, $record, $variant, $statements, $typeclasses)
+}
\ No newline at end of file

src/stages/adt_generator/combinators.raku

+#!/usr/bin/env perl6
+use v6.c;
+use strict;
+use worries;
+use lib '.';
+use Parser;
+
+my $inputADTfile         = @*ARGS[0];
+my $combinators_filename = @*ARGS[1];
+
+my ($adts, $moduleName, $record, $variant, $statements, $typeclasses) = parse($inputADTfile);
+
+$*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 "";
+    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>}), :with(&[eqv])) -> $t
+    { my $ty = $t<ctorsOrFields>[0]<type>;
+      my $typeclass = $typeclasses{$t<kind>};
+      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/generator.raku → src/stages/adt_generator/fold.raku

@@ -2,102 +2,18 @@
 use v6.c;
 use strict;
 use worries;
+use lib '.';
+use Parser;
 
 # TODO: find a way to do mutual recursion between the produced file and some #include-y-thingy
 # TODO: make an .mli
 # TODO: shorthand for `foo list` etc. in field and constructor types
 # TODO: error when reserved names are used ("state", … please list them here)
 
-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_");
-say "\$moduleName is $moduleName";
-my $variant = "_ _variant";
-my $record = "_ _ record";
-sub poly { $^type_name }
-
-my $l = $inputADTfile.IO.lines;
-# TODO: do the inlining recursively?
-$l = $l.map({
-    given $_ {
-        when /^(\(\*\s+)?(open|include) \s+ (<-blank -[\(]>*) \s* \(\*\@ \s* follow \s* (<-blank -[\*]>*) \s* \*\)\s*$/ {
-            flat ["(* $/[2] followed from $/[3] *)"],
-                 $/[3].IO.lines.list,
-                 ["(* end of $/[2] followed from $/[3] *)"]
-        }
-        default { [$_] }
-    }
-}).flat;
-$l = $l.grep(none /^\(\*\@ \s* ignore \s* \*\)/);
-$l = $l.map(*.subst: /(^\s+|\s+$)/, "", :g);
-$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.
-$l = $l.join("\n").subst(/\n+/, "\n", :g); # join lines and remove consecutive newlines
-$l = $l.subst(/\s*\(\* ( <-[\*]> | \*+<-[\*\)]> )* \*\)/, '', :g); # discard comments (incl. multi-line comments)
-$l = $l.split(/\nand\s+/).grep(/./); # split lines again and preserve nonempty lines
-$l = $l.map(*.split("\n"));
-$l = $l.map: {
-    my $ll = $_;
-    my ($name, $kind) = do given $_[0] {
-        when /^((\w|\')+)\s*\=$/   { "$/[0]", $variant }
-        when /^((\w|\')+)\s*\=\s*\{$/ { "$/[0]", $record }
-        when /^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ { "$/[0]", poly("$/[2]") }
-        default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
-    };
-    my $ctorsOrFields = do {
-        when (/^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
-        default {
-            $_[1..*].grep({ ! /^\}?$/ }).map: {
-                when /^\|\s*((\w|\')+)\s*of\s+((\w|\')+)$/ { "$/[0]", "$/[1]" }
-                when /^\|\s*((\w|\')+)$/ { "$/[0]", "" }
-                when /^((\w|\')+)\s*\:\s*((\w|\')+)\s*\;$/ { "$/[0]", "$/[1]" }
-                default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
-            }
-        };
-    }
-    %{
-      "name"          => $name ,
-      "kind"          => $kind ,
-      "ctorsOrFields" => $ctorsOrFields
-    }
-};
-
-my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
-  {
-   "name"          => $name ,
-   "oNewName"      => "O.{$name}", # ($kind ne $record && $kind ne $variant) ?? "$name" !! "O.{$name}",
-   "newName"       => $name ,
-   "kind"          => $kind ,
-   "ctorsOrFields" => @(map -> ($cf, $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 ,
-           oNewName  => "O.{$cf}" ,
-           newName   => $cf ,
-           isBuiltin => $isBuiltin ,
-           type      => $type ,
-           oNewType  => $isBuiltin ?? "$type" !! "O.{$type}" ,
-           newType   => $type ,
-       }
-   }, @ctorsOrFields),
-  }
-}, @$l.cache).list;
+my $inputADTfile    = @*ARGS[0];
+my $folder_filename = @*ARGS[1];
 
+my ($adts, $moduleName, $record, $variant, $statements, $typeclasses) = parse($inputADTfile);
 
 # Auto-generated fold functions
 $*OUT = open $folder_filename, :w;
@@ -339,248 +255,4 @@ $*OUT = open $folder_filename, :w;
     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>}), :with(&[eqv])) -> $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 CheckMapperInputSignature = 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 = \{";
-    say "      fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName";
-    say '    };;';
-
-
-    # fold_map functions
-    say "";
-    for $adts.list -> $t
-    { say "  let _fold_map__$t<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 "";
-      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<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 "";
-      }
-    }
-
-    # 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 = \{";
-    say "      fn =";
-    say "        fun self visitor ->";
-    say '        {';
-    for $adts.list -> $t
-    { say "          $t<name> = \{";
-      say "              node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
-      for $t<ctorsOrFields>.list -> $c
-      { say "              $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
-      say '            };' }
-    say '    }';
-    say '  };;';
-    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<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<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<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 , 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 , O.make__$t<newName>__$c<newName> v)"; } } }
-        } elsif ($t<kind> eq $record) {
-            print '        { ';
-            for $t<ctorsOrFields>.list -> $f
-            { print "$f<name>; "; }
-            say "} ->";
-            for $t<ctorsOrFields>.list -> $f
-            { say "        continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
-            print "        return (state , (O.make__$t<newName>";
-            for $t<ctorsOrFields>.list -> $f
-            { print " ~$f<newName>"; }
-            say " : $t<oNewName>))";
-        } else {
-            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 "        >>? fun (state, x) -> return (state, O.make__$t<name> x);;";
-        }
-    }
-
-    for $adts.list -> $t
-    { say "  let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{";
-      say "    node__$t<name> = no_op_node__$t<name>;";
-      say "    node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
-      say "    node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
-      for $t<ctorsOrFields>.list -> $c
-      { print "    $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
-        if ($c<isBuiltin>) {
-            print "ignore continue; return (state , v)";
-        } else {
-            print "continue.$c<type>.node__$c<type> state v";
-        }
-        say ") ;"; }
-      say '    }' }
-
-    say "  let no_op : type state . (state,_) fold_map_config__$moduleName = \{";
-    for $adts.list -> $t
-    { say "    $t<name> = no_op__$t<name>;" }
-    say '  };;';
-
-    say "";
-    for $adts.list -> $t
-    { say "  let with__$t<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
-      say "  let with__$t<name>__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
-      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 "";
-    for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>}), :with(&[eqv])) -> $t
-    { my $ty = $t<ctorsOrFields>[0]<type>;
-      my $typeclass = $typeclasses{$t<kind>};
-      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;;";
-}
+}
\ No newline at end of file

src/stages/adt_generator/fold_map.raku

+#!/usr/bin/env perl6
+use v6.c;
+use strict;
+use worries;
+use lib '.';
+use Parser;
+
+my $inputADTfile    = @*ARGS[0];
+my $oModuleName     = @*ARGS[1];
+my $mapper_filename = @*ARGS[2];
+
+my ($adts, $moduleName, $record, $variant, $statements, $typeclasses) = parse($inputADTfile);
+
+# 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>}), :with(&[eqv])) -> $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 CheckMapperInputSignature = 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 = \{";
+    say "      fn : ('state, 'err) mk_continue_fold_map -> ('state, 'err) fold_map_config__$moduleName -> ('state, 'err) _continue_fold_map__$moduleName";
+    say '    };;';
+
+
+    # fold_map functions
+    say "";
+    for $adts.list -> $t
+    { say "  let _fold_map__$t<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 "";
+      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<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 "";
+      }
+    }
+
+    # 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 = \{";
+    say "      fn =";
+    say "        fun self visitor ->";
+    say '        {';
+    for $adts.list -> $t
+    { say "          $t<name> = \{";
+      say "              node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
+      for $t<ctorsOrFields>.list -> $c
+      { say "              $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
+      say '            };' }
+    say '    }';
+    say '  };;';
+    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<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<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<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 , 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 , O.make__$t<newName>__$c<newName> v)"; } } }
+        } elsif ($t<kind> eq $record) {
+            print '        { ';
+            for $t<ctorsOrFields>.list -> $f
+            { print "$f<name>; "; }
+            say "} ->";
+            for $t<ctorsOrFields>.list -> $f
+            { say "        continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
+            print "        return (state , (O.make__$t<newName>";
+            for $t<ctorsOrFields>.list -> $f
+            { print " ~$f<newName>"; }
+            say " : $t<oNewName>))";
+        } else {
+            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 "        >>? fun (state, x) -> return (state, O.make__$t<name> x);;";
+        }
+    }
+
+    for $adts.list -> $t
+    { say "  let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{";
+      say "    node__$t<name> = no_op_node__$t<name>;";
+      say "    node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
+      say "    node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
+      for $t<ctorsOrFields>.list -> $c
+      { print "    $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
+        if ($c<isBuiltin>) {
+            print "ignore continue; return (state , v)";
+        } else {
+            print "continue.$c<type>.node__$c<type> state v";
+        }
+        say ") ;"; }
+      say '    }' }
+
+    say "  let no_op : type state . (state,_) fold_map_config__$moduleName = \{";
+    for $adts.list -> $t
+    { say "    $t<name> = no_op__$t<name>;" }
+    say '  };;';
+
+    say "";
+    for $adts.list -> $t
+    { say "  let with__$t<name> : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
+      say "  let with__$t<name>__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
+      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";
+}
\ No newline at end of file

src/test/adt_generator/amodule_utils.ml

@@ -5,7 +5,11 @@ let fold_map__list continue state v =
     let%bind (state , lst') = acc in
     let%bind (state , elt') = continue state elt in
     ok (state , elt' :: lst') in
-  List.fold_left aux (ok (state, [])) v
+  let%bind (state, l) = List.fold_left aux (ok (state, [])) v in
+  (* fold_left with a list accumulator will produce the results in
+     reverse order, so we apply List.rev to put them back in the right
+     order. *)
+  ok (state, List.rev l)
 
 
 let fold_map__option continue state v =

src/test/adt_generator/dune

 (rule
-  (targets generated_fold.ml generated_map.ml generated_o.ml)
-  (deps ../../../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))
+  (targets generated_fold.ml)
+  (deps ../../../src/stages/adt_generator/Parser.pm ../../../src/stages/adt_generator/fold.raku amodule.ml)
+  (action (run perl6 -I ../../../src/stages/adt_generator/ ../../../src/stages/adt_generator/fold.raku amodule.ml generated_fold.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_o.ml)
+  (deps ../../../src/stages/adt_generator/Parser.pm ../../../src/stages/adt_generator/combinators.raku amodule.ml)
+  (action (run perl6 -I ../../../src/stages/adt_generator/ ../../../src/stages/adt_generator/combinators.raku amodule.ml generated_o.ml))
+  (mode (promote (until-clean) (only *)))
+)
+(rule
+  (targets generated_map.ml)
+  (deps ../../../src/stages/adt_generator/Parser.pm ../../../src/stages/adt_generator/fold_map.raku amodule.ml)
+  (action (run perl6 -I ../../../src/stages/adt_generator/ ../../../src/stages/adt_generator/fold_map.raku amodule.ml Generated_o generated_map.ml))
   (mode (promote (until-clean) (only *)))
 )
 

src/test/contracts/expected/check_signature.religo.expected

 let check_signature = (param: (key, signature, bytes)): bool => {
-  let (pk, signed, msg) = param;
+  let pk, signed, msg = param;
   Crypto.check(pk, signed, msg)
 };