diff --git a/src/stages/adt_generator/generator.pl b/src/stages/adt_generator/generator.pl new file mode 100644 index 000000000..c145a5b4b --- /dev/null +++ b/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 "}"; diff --git a/src/stages/adt_generator/generator.py b/src/stages/adt_generator/generator.py index 48b8c5fd4..e4af0468a 100644 --- a/src/stages/adt_generator/generator.py +++ b/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("") @@ -155,8 +164,8 @@ for t in adts: for c in t.ctorsOrFields: print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ') if c.isBuiltin: - print("ignore continue; (v, state)", end=' ') + print("ignore continue; (v, state)", end='') else: - print(f"continue.{c.type_} v state", end=' ') + print(f"continue.{c.type_} v state", end='') print(") ;") print("}") diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku new file mode 100644 index 000000000..e4912da3f --- /dev/null +++ b/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 ="; + if ($t eq $variant) { + for $t.list -> $c + { say " | $c of $c" } + } elsif ($t eq $record) { + say ' {'; + for $t.list -> $f + { say " $f : $f ;"; } + say ' }'; + } else { + print " "; + for $t.list -> $a + { print "$a "; } + print "$t"; + say ""; + } +} + +say ""; +say "type 'state continue_fold ="; +say ' {'; +for $adts.list -> $t +{ say " $t : $t -> 'state -> ($t * 'state) ;"; + for $t.list -> $c + { say " $t_$c : $c -> 'state -> ($c * 'state) ;" } } +say ' }'; + +say ""; +say "type 'state fold_config ="; +say ' {'; +for $adts.list -> $t +{ say " $t : $t -> 'state -> ('state continue_fold) -> ($t * 'state) ;"; + say " $t_pre_state : $t -> 'state -> 'state ;"; + say " $t_post_state : $t -> $t -> 'state -> 'state ;"; + for $t.list -> $c + { say " $t_$c : $c -> 'state -> ('state continue_fold) -> ($c * '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 = fold_$t visitor ;"; + for $t.list -> $c + { say " $t_$c = fold_$t_$c visitor ;"; } } +say '}'; +say ""; + +for $adts.list -> $t +{ say "and fold_$t : type state . state fold_config -> $t -> state -> ($t * state) = fun visitor x state ->"; + say " let continue_fold : state continue_fold = mk_continue_fold visitor in"; + say " let state = visitor.$t_pre_state x state in"; + say " let (new_x, state) = visitor.$t x state continue_fold in"; + say " let state = visitor.$t_post_state x new_x state in"; + say " (new_x, state)"; + say ""; + for $t.list -> $c + { say "and fold_$t_$c : type state . state fold_config -> $c -> state -> ($c * state) = fun visitor x state ->"; + say " let continue_fold : state continue_fold = mk_continue_fold visitor in"; + say " visitor.$t_$c x state continue_fold"; + say ""; } } + +say "let no_op : 'a fold_config = \{"; +for $adts.list -> $t +{ say " $t = (fun v state continue ->"; + say " match v with"; + if ($t eq $variant) { + for $t.list -> $c + { say " | $c v -> let (v, state) = continue.$t_$c v state in ($c v, state)"; } + } elsif ($t eq $record) { + print ' { '; + for $t.list -> $f + { print "$f; "; } + say "} ->"; + for $t.list -> $f + { say " let ($f, state) = continue.$t_$f $f state in"; } + print ' ({ '; + for $t.list -> $f + { print "$f; "; } + say '}, state)'; + } else { + print " v -> fold_$t v state ( "; + print ( "continue.$t_$_" for $t.list ).join(", "); + say " )"; + } + say " );"; + say " $t_pre_state = (fun v state -> ignore v; state) ;"; + say " $t_post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; + for $t.list -> $c + { print " $t_$c = (fun v state continue -> "; + if ($c) { + print "ignore continue; (v, state)"; + } else { + print "continue.$c v state"; + } + say ") ;"; } } +say '}';