balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ADT generator: Fixes LIGO-656 Generated fold_maps are unusable because some collection types need extra info (e.g. sets need a comparison operator for their elements)

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-05-20 20:15:36 +01:00
parent b2d80e0154
commit 9a017e5f63
14 changed files with 477 additions and 424 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/stages/4-ast_typed/.gitignore vendored
View File

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

1
src/stages/4-ast_typed/PP_generic.ml
View File

@ -1,3 +1,4 @@
open Types
open Fold
open Format
open PP_helpers

8
src/stages/4-ast_typed/ast.ml
View File

@ -1,6 +1,12 @@
[@@@warning "-30"]
include Types_utils
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. *)
(*@ typeclass poly_unionfind comparable *)
(*@ typeclass poly_set comparable *)
type type_constant =
| TC_unit

7
src/stages/4-ast_typed/dune
View File

@ -1,7 +1,7 @@
(rule
(target generated_fold.ml)
(deps ../adt_generator/generator.raku types.ml)
(action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml)))
(targets generated_fold.ml generated_map.ml generated_o.ml)
(deps ../adt_generator/generator.raku ast.ml)
(action (run perl6 ../adt_generator/generator.raku ast.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml))
(mode (promote (until-clean) (only *)))
)
@ -19,5 +19,6 @@
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
;; (modules_without_implementation generated_fold_x)
(flags (:standard -open Simple_utils))
)

2
src/stages/4-ast_typed/fold.ml
View File

@ -1 +1,3 @@
include Generated_fold
module M1 = struct include Generated_map end
module M2 = struct include Generated_o end

5
src/stages/4-ast_typed/types.ml Normal file
View File

@ -0,0 +1,5 @@
(* 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

17
src/stages/4-ast_typed/types_utils.ml
View File

@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe
type location = Location.t
type inline = bool
type 'a extra_info__comparable = {
compare : 'a -> 'a -> int ;
}
let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result =
fun f state m ->
let aux k v acc =
@ -93,9 +97,9 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t
type 'a poly_set = 'a RedBlackTrees.PolySet.t
let fold_map__poly_unionfind : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
fun f state l ->
ignore (f, state, l) ; failwith "TODO
let fold_map__poly_unionfind : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result =
fun extra_info f state l ->
ignore (extra_info, f, state, l) ; failwith "TODO
let aux acc element =
let%bind state , l = acc in
let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
@ -114,12 +118,13 @@ let fold_map__PolyMap : type k v state new_v . (state -> v -> (state * new_v) re
let fold_map__typeVariableMap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a typeVariableMap -> (state * new_a typeVariableMap) result =
fold_map__PolyMap
let fold_map__poly_set : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
fun f state s ->
let new_compare : (new_a -> new_a -> int) = failwith "TODO: thread enough information about the target AST so that we may compare things here." in
let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (state -> a -> (state * new_a) result) -> state -> a poly_set -> (state * new_a poly_set) result =
fun extra_info f state s ->
let new_compare : (new_a -> new_a -> int) = extra_info.compare in
let aux elt ~acc =
let%bind (state , s) = acc in
let%bind (state , new_elt) = f state elt in
ok (state , PolySet.add new_elt s) in
let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in
ok (state , m)

426
src/stages/adt_generator/generator.raku
View File

@ -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,174 +60,43 @@ $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 {
say "$statement"
}
say "open Adt_generator.Common;;";
for $statements -> $statement { say "$statement" }
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 ' {';
say " type ('state , 'adt_info_node_instance_info) _fold_config = \{";
say " generic : 'state -> 'adt_info_node_instance_info -> 'state;";
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
@ -226,19 +105,20 @@ for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}
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 ' };;';
say "module Arg = struct";
say "";
say " module Adt_info = Adt_generator.Generic.Adt_info (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 " end);;";
say " include Adt_info;;";
say " type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;";
say "";
say 'type blahblah = {';
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> : 'state . the_folds -> 'state fold_config -> 'state -> $t<name> -> '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> : 'state . the_folds -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
say ' };;';
# generic programming info about the nodes and fields
@ -250,14 +130,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 qstate . the_folds -> qstate fold_config -> {$c<type> || 'unit'} -> 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 +152,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 qstate . the_folds -> qstate fold_config -> $t<name> -> 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 " constructor = (match x with";
for $t<ctorsOrFields>.list -> $c { say " | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> blahblah visitor { $c<type> ?? 'v' !! '()' }"; }
say " instance_kind =";
say ' VariantInstance {';
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 +178,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 +188,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 +208,33 @@ 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 qstate . the_folds -> qstate fold_config -> qstate -> $t<name> -> 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 " 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 qstate . the_folds -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun the_folds { $c<type> ?? 'visitor' !! '_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";
if ($c<type> eq '') {
# nothing to do, this constructor has no arguments.
say " ignore blahblah; state;;";
say " ignore the_folds; 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 "";
}
}
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 +244,97 @@ 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 qstate . qstate fold_config -> qstate -> $t<name> -> 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 qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> the_folds visitor state x;;" } }
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.list -> $t
{ say " let $t<name> = M.f fold__$t<name>;;"; }
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 $tc = $typeclasses{$t<kind>};
say " val extra_info__{$ty}__$tc : $ty extra_info__$tc;;"; }
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 +345,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 +380,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>)"; }
default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } }
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
@ -427,14 +404,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>; "; }
say "\} : $t<newName>))";
{ print " ~$f<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 +448,52 @@ 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.list -> $t
{ say "let $t<name> = M.f fold__$t<name>;;"; }
say "end";
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant && $typeclasses{$_<kind>}}).unique(:as({$_<ctorsOrFields>, $_<kind>})) -> $t
{ my $ty = $t<ctorsOrFields>[0]<type>;
my $tc = $typeclasses{$t<kind>};
say "let extra_info__{$ty}__$tc : $ty extra_info__$tc = \{ compare = (fun a b -> let () = failwith \"TODO\" in Pervasives.compare a b) \};;"; }
# 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;;";
}

2
src/test/adt_generator/.gitignore vendored
View File

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

1
src/test/adt_generator/amodule.ml
View File

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

4
src/test/adt_generator/dune
View File

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

1
src/test/adt_generator/fold.ml
View File

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

8
src/test/adt_generator/use_a_fold.ml
View File

@ -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, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in
ok (state + 1, { a1__' ; a2__' }))
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
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