Added Perl 5 and Raku (A.K.A. Perl 6) translations of the ADT generator. Their outputs are identical.

src/stages/adt_generator/generator.pl

@@ -0,0 +1,212 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use 5.010;
+use Data::Dumper; $Data::Dumper::Useqq = 1; # use double quotes when dumping (we have a few "prime'" names)
+sub enumerate { my $i = 0; [map { [ $i++, $_ ] } @{$_[0]}] }
+
+my $moduleName = "A";
+my $variant = "_ _variant";
+my $record = "_ _ record"; my $true = 1; my $false = 0;
+sub poly { $_[0] }
+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"]
+     ]],
+    ];
+
+
+
+
+my $adts = [map {
+  my ($name , $kind, $ctorsOrFields) = @$_;
+  {
+   "name"          => $name ,
+   "newName"       => "${name}'" ,
+   "kind"          => $kind ,
+   "ctorsOrFields" => [map {
+       my ($cf, $isBuiltin, $type) = @$_;
+       {
+           name      => $cf ,
+           newName   => "${cf}'" ,
+           isBuiltin => $isBuiltin ,
+           type      => $type ,
+           newType   => $isBuiltin ? $type : "${type}'"
+       }
+   } @$ctorsOrFields],
+  }
+} @$adts_raw];
+
+# print Dumper $adts ;
+
+say "(* This is an auto-generated file. Do not edit. *)";
+
+say "";
+say "open ${moduleName}";
+
+say "";
+foreach (@{enumerate($adts)}) {
+  my ($index, $t) = @$_;
+  my %t = %$t;
+  my $typeOrAnd = $index == 0 ? "type" : "and";
+  say "${typeOrAnd} $t{newName} =";
+  if ($t{kind} eq $variant) {
+      foreach (@{$t{ctorsOrFields}}) {
+          my %c = %$_;
+          say "  | $c{newName} of $c{newType}"
+      }
+  }
+  elsif ($t{kind} eq $record) {
+      say "  {";
+      foreach (@{$t{ctorsOrFields}}) {
+          my %f = %$_;
+          say "    $f{newName} : $f{newType} ;";
+      }
+      say "  }";
+  } else {
+      print "  ";
+      foreach (@{$t{ctorsOrFields}}) {
+          my %a = %$_;
+          print "$a{newType} ";
+      }
+      print "$t{kind}";
+      say "";
+  }
+}
+
+say "";
+say "type 'state continue_fold =";
+say "  {";
+foreach (@$adts) {
+    my %t = %$_;
+    say "    $t{name} : $t{name} -> 'state -> ($t{newName} * 'state) ;";
+    foreach (@{$t{ctorsOrFields}}) {
+        my %c = %$_;
+        say "    $t{name}_$c{name} : $c{type} -> 'state -> ($c{newType} * 'state) ;"
+    }
+}
+say "  }";
+
+say "";
+say "type 'state fold_config =";
+say "  {";
+foreach (@$adts) {
+    my %t = %$_;
+    say "    $t{name} : $t{name} -> 'state -> ('state continue_fold) -> ($t{newName} * 'state) ;";
+    say "    $t{name}_pre_state : $t{name} -> 'state -> 'state ;";
+    say "    $t{name}_post_state : $t{name} -> $t{newName} -> 'state -> 'state ;";
+    foreach (@{$t{ctorsOrFields}}) {
+        my %c = %$_;
+        say "    $t{name}_$c{name} : $c{type} -> 'state -> ('state continue_fold) -> ($c{newType} * 'state) ;";
+    }
+}
+say "  }";
+
+say "";
+say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
+say "let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->";
+say "  {";
+foreach (@$adts) {
+    my %t = %$_;
+    say "    $t{name} = fold_$t{name} visitor ;";
+    foreach (@{$t{ctorsOrFields}}) {
+        my %c = %$_;
+        say "    $t{name}_$c{name} = fold_$t{name}_$c{name} visitor ;";
+    }
+}
+say "}";
+say "";
+
+foreach (@$adts) {
+    my %t = %$_;
+    say "and fold_$t{name} : type state . state fold_config -> $t{name} -> state -> ($t{newName} * state) = fun visitor x state ->";
+  say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
+  say "  let state = visitor.$t{name}_pre_state x state in";
+  say "  let (new_x, state) = visitor.$t{name} x state continue_fold in";
+  say "  let state = visitor.$t{name}_post_state x new_x state in";
+  say "  (new_x, state)";
+  say "";
+  foreach (@{$t{ctorsOrFields}}) {
+      my %c = %$_;
+      say "and fold_$t{name}_$c{name} : type state . state fold_config -> $c{type} -> state -> ($c{newType} * state) = fun visitor x state ->";
+      say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
+      say "  visitor.$t{name}_$c{name} x state continue_fold";
+      say "";
+  }
+}
+
+say "let no_op : 'a fold_config = {";
+foreach (@$adts) {
+    my %t = %$_;
+    say "  $t{name} = (fun v state continue ->";
+    say "    match v with";
+    if ($t{kind} eq $variant) {
+        foreach (@{$t{ctorsOrFields}}) {
+            my %c = %$_;
+            say "    | $c{name} v -> let (v, state) = continue.$t{name}_$c{name} v state in ($c{newName} v, state)";
+        }
+    } elsif ($t{kind} eq $record) {
+        print "      { ";
+        foreach (@{$t{ctorsOrFields}}) {
+            my %f = %$_;
+            print "$f{name}; ";
+        }
+        say "} ->";
+        foreach (@{$t{ctorsOrFields}}) {
+            my %f = %$_;
+            say "      let ($f{newName}, state) = continue.$t{name}_$f{name} $f{name} state in";
+        }
+        print "      ({ ";
+        foreach (@{$t{ctorsOrFields}}) {
+            my %f = %$_;
+            print "$f{newName}; "
+        }
+        say "}, state)";
+    } else {
+        print "      v -> fold_$t{kind} v state ( ";
+        print join(", ", map { my %f = %$_; "continue.$t{name}_$f{name}" } @{$t{ctorsOrFields}});
+        say " )";
+    }
+    say "  );";
+    say "  $t{name}_pre_state = (fun v state -> ignore v; state) ;";
+    say "  $t{name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;";
+    foreach (@{$t{ctorsOrFields}}) {
+        my %c = %$_;
+        print "  $t{name}_$c{name} = (fun v state continue -> ";
+        if ($c{isBuiltin}) {
+            print "ignore continue; (v, state)";
+        } else {
+            print "continue.$c{type} v state";
+        }
+        say ") ;";
+    }
+}
+say "}";

src/stages/adt_generator/generator.py

@@ -1,3 +1,10 @@
+#!/usr/bin/env python3
+import pprint
+
+
+
+
+
 moduleName = "A"
 variant="_ _variant"
 record="_ _record"
@@ -58,6 +65,8 @@ adts = [
   for (name, kind, ctors) in adts
 ]
 
+# pprint.PrettyPrinter(compact=False, indent=4).pprint(adts)
+
 print("(* This is an auto-generated file. Do not edit. *)")
 
 print("")

src/stages/adt_generator/generator.raku

@@ -0,0 +1,176 @@
+#!/usr/bin/env perl6
+use strict;
+use v6;
+use v6.c;
+use worries;
+
+
+my $moduleName = "A";
+my $variant = "_ _variant";
+my $record = "_ _ record";
+sub poly { $^type_name }
+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;
+
+# say $adts.perl ;
+
+say "(* This is an auto-generated file. Do not edit. *)";
+
+say "";
+say "open $moduleName";
+
+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
+      { say "  | $c<newName> of $c<newType>" }
+  } 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 "type 'state continue_fold =";
+say '  {';
+for $adts.list -> $t
+{ say "    $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
+  for $t<ctorsOrFields>.list -> $c
+  { say "    $t<name>_$c<name> : $c<type> -> 'state -> ($c<newType> * 'state) ;" } }
+say '  }';
+
+say "";
+say "type 'state fold_config =";
+say '  {';
+for $adts.list -> $t
+{ say "    $t<name> : $t<name> -> 'state -> ('state continue_fold) -> ($t<newName> * 'state) ;";
+  say "    $t<name>_pre_state : $t<name> -> 'state -> 'state ;";
+  say "    $t<name>_post_state : $t<name> -> $t<newName> -> 'state -> 'state ;";
+  for $t<ctorsOrFields>.list -> $c
+  { say "    $t<name>_$c<name> : $c<type> -> 'state -> ('state continue_fold) -> ($c<newType> * 'state) ;";
+  } }
+say '  }';
+
+say "";
+say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
+say "let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->";
+say '  {';
+for $adts.list -> $t
+{ say "    $t<name> = fold_$t<name> visitor ;";
+  for $t<ctorsOrFields>.list -> $c
+  { say "    $t<name>_$c<name> = fold_$t<name>_$c<name> visitor ;"; } }
+say '}';
+say "";
+
+for $adts.list -> $t
+{ say "and fold_$t<name> : type state . state fold_config -> $t<name> -> state -> ($t<newName> * state) = fun visitor x state ->";
+  say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
+  say "  let state = visitor.$t<name>_pre_state x state in";
+  say "  let (new_x, state) = visitor.$t<name> x state continue_fold in";
+  say "  let state = visitor.$t<name>_post_state x new_x state in";
+  say "  (new_x, state)";
+  say "";
+  for $t<ctorsOrFields>.list -> $c
+  { say "and fold_$t<name>_$c<name> : type state . state fold_config -> $c<type> -> state -> ($c<newType> * state) = fun visitor x state ->";
+    say "  let continue_fold : state continue_fold = mk_continue_fold visitor in";
+    say "  visitor.$t<name>_$c<name> x state continue_fold";
+    say ""; } }
+
+say "let no_op : 'a fold_config = \{";
+for $adts.list -> $t
+{ say "  $t<name> = (fun v state continue ->";
+  say "    match v with";
+  if ($t<kind> eq $variant) {
+    for $t<ctorsOrFields>.list -> $c
+    { say "    | $c<name> v -> let (v, state) = continue.$t<name>_$c<name> v state in ($c<newName> v, state)"; }
+  } elsif ($t<kind> eq $record) {
+    print '      { ';
+    for $t<ctorsOrFields>.list -> $f
+    { print "$f<name>; "; }
+    say "} ->";
+    for $t<ctorsOrFields>.list -> $f
+    { say "      let ($f<newName>, state) = continue.$t<name>_$f<name> $f<name> state in"; }
+    print '      ({ ';
+    for $t<ctorsOrFields>.list -> $f
+    { print "$f<newName>; "; }
+    say '}, state)';
+  } else {
+    print "      v -> fold_$t<kind> v state ( ";
+    print ( "continue.$t<name>_$_<name>" for $t<ctorsOrFields>.list ).join(", ");
+    say " )";
+  }
+  say "  );";
+  say "  $t<name>_pre_state = (fun v state -> ignore v; state) ;";
+  say "  $t<name>_post_state = (fun v new_v state -> ignore (v, new_v); state) ;";
+  for $t<ctorsOrFields>.list -> $c
+  { print "  $t<name>_$c<name> = (fun v state continue -> ";
+    if ($c<isBuiltin>) {
+      print "ignore continue; (v, state)";
+    } else {
+      print "continue.$c<type> v state";
+    }
+    say ") ;"; } }
+say '}';