From 9a017e5f63a9c5951abee6b55ff005ee58654a6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 20 May 2020 20:15:36 +0100 Subject: [PATCH] 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) --- src/stages/4-ast_typed/.gitignore | 3 +- src/stages/4-ast_typed/PP_generic.ml | 1 + src/stages/4-ast_typed/ast.ml | 8 +- src/stages/4-ast_typed/dune | 7 +- src/stages/4-ast_typed/fold.ml | 2 + src/stages/4-ast_typed/types.ml | 5 + src/stages/4-ast_typed/types_utils.ml | 17 +- src/stages/adt_generator/generator.raku | 824 ++++++++++++------------ src/stages/adt_generator/generic.ml | 18 +- src/test/adt_generator/.gitignore | 2 + src/test/adt_generator/amodule.ml | 1 + src/test/adt_generator/dune | 4 +- src/test/adt_generator/fold.ml | 1 + src/test/adt_generator/use_a_fold.ml | 8 +- 14 files changed, 477 insertions(+), 424 deletions(-) create mode 100644 src/stages/4-ast_typed/types.ml diff --git a/src/stages/4-ast_typed/.gitignore b/src/stages/4-ast_typed/.gitignore index 39f5407d5..189a4ee60 100644 --- a/src/stages/4-ast_typed/.gitignore +++ b/src/stages/4-ast_typed/.gitignore @@ -1,2 +1,3 @@ /generated_fold.ml - +/generated_map.ml +/generated_o.ml diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index c36fcebcb..502ee88fa 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -1,3 +1,4 @@ +open Types open Fold open Format open PP_helpers diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index be7a7a287..c9f17ac5f 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -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 diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune index 874a19c0a..b2993c400 100644 --- a/src/stages/4-ast_typed/dune +++ b/src/stages/4-ast_typed/dune @@ -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)) ) diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml index 271974820..f1a08e4cb 100644 --- a/src/stages/4-ast_typed/fold.ml +++ b/src/stages/4-ast_typed/fold.ml @@ -1 +1,3 @@ include Generated_fold +module M1 = struct include Generated_map end +module M2 = struct include Generated_o end diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml new file mode 100644 index 000000000..6f4ee13b2 --- /dev/null +++ b/src/stages/4-ast_typed/types.ml @@ -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 diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 2c77f5c7d..337e76ba0 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -32,6 +32,10 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe type location = Location.t type inline = bool +type 'a extra_info__comparable = { + compare : 'a -> 'a -> int ; +} + let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result = fun f state m -> let aux k v acc = @@ -93,9 +97,9 @@ type 'v typeVariableMap = (type_variable, 'v) RedBlackTrees.PolyMap.t type 'a poly_set = 'a RedBlackTrees.PolySet.t -let fold_map__poly_unionfind : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a poly_unionfind -> (state * new_a poly_unionfind) Simple_utils.Trace.result = - 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) + diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 8b323c157..99c5c1a56 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -8,17 +8,27 @@ use worries; # TODO: shorthand for `foo list` etc. in field and constructor types # TODO: error when reserved names are used ("state", … please list them here) -my $moduleName = @*ARGS[0].subst(/\.ml$/, '').samecase("A_"); +my $inputADTfile = @*ARGS[0]; +my $oModuleName = @*ARGS[1]; +my $combinators_filename = @*ARGS[2]; +my $folder_filename = @*ARGS[3]; +my $mapper_filename = @*ARGS[4]; + +my $moduleName = $inputADTfile.subst(/\.ml$/, '').samecase("A_"); my $variant = "_ _variant"; my $record = "_ _ record"; sub poly { $^type_name } -my $l = @*ARGS[0].IO.lines; +my $l = $inputADTfile.IO.lines; $l = $l.map(*.subst: /(^\s+|\s+$)/, ""); $l = $l.list.cache; my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/; my $statements = $l.grep($statement_re); $l = $l.grep(none $statement_re); +$l = $l.list.cache; +my $typeclass_re = /^\(\*\@ \s* typeclass \s+ (\w+) \s+ (\w+) \s* \*\)/; +my $typeclasses = %($l.grep($typeclass_re).map({ do given $_ { when $typeclass_re { %{ "$/[0]" => "$/[1]" } } } }).flat); +$l = $l.grep(none $typeclass_re); $statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, '')); $l = $l.cache.map(*.subst: /^type\s+/, "\nand "); # TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose. @@ -50,424 +60,440 @@ $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({ $_ eq $type })); + my $resolvedType = $type && $l.cache.first({ $_ eq $type }); + my $isBuiltin = (! $type) || (! $resolvedType); + # my $isPoly = $resolvedType && $resolvedType ne $record && $resolvedType 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 ; - -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 "(* must be provided by one of the open or include statements: *)"; -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).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 ="; - if ($t eq $variant) { - for $t.list -> $c { - given $c { - when '' { say " | $c" } - default { say " | $c of $c" } - } - } - say ""; - } 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 ""; -for $adts.list -> $t { - say "type ('state, 'err) _continue_fold_map__$t = \{"; - say " node__$t : 'state -> $t -> ('state * $t , 'err) monad ;"; - for $t.list -> $c - { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'} , 'err) monad ;" } - say ' };;'; -} - -say "type ('state , 'err) _continue_fold_map__$moduleName = \{"; -for $adts.list -> $t { - say " $t : ('state , 'err) _continue_fold_map__$t ;"; -} -say ' };;'; - -say ""; -for $adts.list -> $t -{ say "type ('state, 'err) fold_map_config__$t = \{"; - say " node__$t : 'state -> $t -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t , 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__pre_state : 'state -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__post_state : 'state -> $t -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) - for $t.list -> $c - { say " $t__$c : 'state -> {$c || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c || '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 : ('state, 'err) fold_map_config__$t;" } -say ' };;'; - -say "include Adt_generator.Generic.BlahBluh"; -say "type ('state , 'adt_info_node_instance_info) _fold_config ="; -say ' {'; -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({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin -{ say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; } -# look for built-in polymorphic types -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).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 " type nonrec ('state , 'adt_info_node_instance_info) fold_config = ('state , 'adt_info_node_instance_info) _fold_config;;"; -say "end;;"; -say "module Adt_info = Adt_generator.Generic.Adt_info (Arg);;"; -say "include Adt_info;;"; -say "type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;"; - -say ""; -say 'type blahblah = {'; -for $adts.list -> $t -{ say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; - for $t.list -> $c - { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } -say '};;'; - -# generic programming info about the nodes and fields -say ""; -for $adts.list -> $t -{ for $t.list -> $c - { say "(* info for field or ctor $t.$c *)"; - say "let info__$t__$c : Adt_info.ctor_or_field = \{"; - say " name = \"$c\";"; - say " is_builtin = {$c ?? 'true' !! 'false'};"; - say " type_ = \"$c\";"; - say '}'; - say ""; - say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; - say " cf = info__$t__$c;"; - say " cf_continue = (fun state -> blahblah.fold__$t__$c blahblah visitor state x);"; - say " cf_new_fold = (fun visitor state -> blahblah.fold__$t__$c blahblah visitor state x);"; - say '};;'; - say ""; } - say "(* info for node $t *)"; - say "let info__$t : Adt_info.node = \{"; - my $kind = do given $t { - when $record { "Record" } - when $variant { "Variant" } - default { "Poly \"$_\"" } - }; - say " kind = $kind;"; - say " declaration_name = \"$t\";"; - print " ctors_or_fields = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } - say "];"; - say '};;'; - say ""; - # TODO: factor out some of the common bits here. - say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->"; - say '{'; - say " instance_declaration_name = \"$t\";"; - do given $t { - when $record { - say ' instance_kind = RecordInstance {'; - print " fields = [ "; - for $t.list -> $c { print "continue_info__$t__$c blahblah visitor x.$c ; "; } - say " ];"; - say '};'; - } - when $variant { - say ' instance_kind = VariantInstance {'; - say " constructor = (match x with"; - for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c blahblah visitor { $c ?? 'v' !! '()' }"; } - say " );"; - print " variant = [ "; - for $t.list -> $c { print "info__$t__$c ; "; } - say "];"; - say '};'; - } - default { - say ' instance_kind = PolyInstance {'; - say " poly = \"$_\";"; - print " arguments = ["; - # TODO: sort by c (currently we only have one-argument - # polymorphic types so it happens to work but should be fixed. - for $t.list -> $c { print "\"$c\""; } - say "];"; - print " poly_continue = (fun state -> visitor.$_ visitor ("; - print $t - .map(-> $c { "(fun state x -> (continue_info__$t__$c blahblah visitor x).cf_continue state)" }) - .join(", "); - say ") state x);"; - say '};'; - } - }; - say '};;'; - say ""; } - -say ""; -say "(* info for adt $moduleName *)"; -print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; -for $adts.list -> $t -{ print "info__$t ; "; } -say "];;"; - -# fold functions -say ""; -for $adts.list -> $t -{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> qstate -> $t -> qstate = fun blahblah 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 blahblah visitor x"; - say ' } in'; - # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic state node_instance_info;;"; - say ""; - for $t.list -> $c - { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; - # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; - if ($c eq '') { - # nothing to do, this constructor has no arguments. - say " ignore blahblah; state;;"; - } elsif ($c) { - say " ignore blahblah; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) - } else { - say " blahblah.fold__$c blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) - } - # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; - say ""; } -} - -say ""; -say 'let blahblah : blahblah = {'; -for $adts.list -> $t -{ say " fold__$t;"; - for $t.list -> $c - { say " fold__$t__$c;" } } -say '};;'; - -# Tying the knot -say ""; -for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x;;"; - for $t.list -> $c - { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x;;" } } - - -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 : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t, 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.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " return (state, new_x);;"; - say ""; - for $t.list -> $c - { say "let _fold_map__$t__$c : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || '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.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) - 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 ' {'; -for $adts.list -> $t -{ say " $t = \{"; - say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; - for $t.list -> $c - { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } - say ' };' } -say ' }'; -say '};;'; -say ""; - -# fold_map functions : tying the knot -say ""; -for $adts.list -> $t -{ say "let fold_map__$t : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t,err) monad ="; - say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; - for $t.list -> $c - { say "let fold_map__$t__$c : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' },err) monad ="; - say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } - - -for $adts.list -> $t +# Auto-generated fold functions +$*OUT = open $folder_filename, :w; { - say "let no_op_node__$t : type state . state -> $t -> (state,_) _continue_fold_map__$moduleName -> (state * $t,_) monad ="; - say " fun state v continue ->"; # (*_info*) - say " match v with"; - if ($t eq $variant) { - for $t.list -> $c - { given $c { - when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , $c)"; } - default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , $c v)"; } } } - } elsif ($t eq $record) { - print ' { '; - for $t.list -> $f - { print "$f; "; } - say "} ->"; - for $t.list -> $f - { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } - print ' return (state , ({ '; - for $t.list -> $f - { print "$f; "; } - say "\} : $t))"; - } else { - print " v -> fold_map__$t ( "; - print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " ) state v;;"; - } + say "(* This is an auto-generated file. Do not edit. *)"; + say ""; + for $statements -> $statement { say "$statement" } + say "open $moduleName;;"; + + say ""; + say " include Adt_generator.Generic.BlahBluh"; + 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({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin + { say " $builtin : ('state , 'adt_info_node_instance_info) _fold_config -> 'state -> $builtin -> 'state;"; } + # look for built-in polymorphic types + for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly + { say " $poly : 'a . ('state , 'adt_info_node_instance_info) _fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } + say ' };;'; + + 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 " include Adt_info;;"; + say " type 'state fold_config = ('state , 'state Adt_info.node_instance_info) _fold_config;;"; + + say ""; + say ' type the_folds = {'; + for $adts.list -> $t + { say " fold__$t : 'state . the_folds -> 'state fold_config -> 'state -> $t -> 'state;"; + for $t.list -> $c + { say " fold__$t__$c : 'state . the_folds -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } + say ' };;'; + + # generic programming info about the nodes and fields + say ""; + for $adts.list -> $t + { for $t.list -> $c + { say " (* info for field or ctor $t.$c *)"; + say " let info__$t__$c : Adt_info.ctor_or_field = \{"; + say " name = \"$c\";"; + say " is_builtin = {$c ?? 'true' !! 'false'};"; + say " type_ = \"$c\";"; + say ' };;'; + # say ""; + say " let continue_info__$t__$c : type qstate . the_folds -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun the_folds visitor x -> \{"; + say " cf = info__$t__$c;"; + say " cf_continue = (fun state -> the_folds.fold__$t__$c the_folds visitor state x);"; + say " cf_new_fold = (fun visitor state -> the_folds.fold__$t__$c the_folds visitor state x);"; + say ' };;'; + # say ""; + } + say " (* info for node $t *)"; + say " let info__$t : Adt_info.node = \{"; + my $kind = do given $t { + when $record { "Record" } + when $variant { "Variant" } + default { "Poly \"$_\"" } + }; + say " kind = $kind;"; + say " declaration_name = \"$t\";"; + print " ctors_or_fields = [ "; + for $t.list -> $c { print "info__$t__$c ; "; } + say "];"; + say ' };;'; + # say ""; + # TODO: factor out some of the common bits here. + say " let continue_info__$t : type qstate . the_folds -> qstate fold_config -> $t -> qstate Adt_info.instance = fun the_folds visitor x ->"; + say ' {'; + say " instance_declaration_name = \"$t\";"; + do given $t { + when $record { + say ' instance_kind = RecordInstance {'; + print " fields = [ "; + for $t.list -> $c { print "continue_info__$t__$c the_folds visitor x.$c ; "; } + say " ];"; + say ' };'; + } + when $variant { + say " instance_kind ="; + say ' VariantInstance {'; + say " constructor ="; + say " (match x with"; + for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c the_folds visitor { $c ?? 'v' !! '()' }"; } + say " );"; + print " variant = [ "; + for $t.list -> $c { print "info__$t__$c ; "; } + say "];"; + say ' };'; + } + default { + say " instance_kind ="; + say ' PolyInstance {'; + say " poly = \"$_\";"; + print " arguments = ["; + # TODO: sort by c (currently we only have one-argument + # polymorphic types so it happens to work but should be fixed. + for $t.list -> $c { print "\"$c\""; } + say "];"; + print " poly_continue = (fun state -> visitor.$_ visitor ("; + print $t + .map(-> $c { "(fun state x -> (continue_info__$t__$c the_folds visitor x).cf_continue state)" }) + .join(", "); + say ") state x);"; + say ' };'; + } + }; + say ' };;'; + # say ""; + } + + say ""; + say " (* info for adt $moduleName *)"; + print " let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; + for $adts.list -> $t + { print "info__$t ; "; } + say "];;"; + + # fold functions + say ""; + for $adts.list -> $t + { say " let fold__$t : type qstate . the_folds -> qstate fold_config -> qstate -> $t -> 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 the_folds visitor x"; + say ' } in'; + # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; + say " visitor.generic state node_instance_info;;"; + # say ""; + for $t.list -> $c + { say " let fold__$t__$c : type qstate . the_folds -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun the_folds { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; + # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; + if ($c eq '') { + # nothing to do, this constructor has no arguments. + say " ignore the_folds; state;;"; + } elsif ($c) { + say " ignore the_folds; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + } else { + say " the_folds.fold__$c the_folds visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + } + # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; + # say ""; + } + } + + say ""; + say ' let the_folds : the_folds = {'; + for $adts.list -> $t + { say " fold__$t;"; + for $t.list -> $c + { say " fold__$t__$c;" } } + say ' };;'; + + # Tying the knot + say ""; + for $adts.list -> $t + { say " let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t the_folds visitor state x;;"; + for $t.list -> $c + { say " let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c 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 = M.f fold__$t;;"; } + say " end"; } -for $adts.list -> $t -{ say "let no_op__$t : type state . (state,_) fold_map_config__$t = \{"; - say " node__$t = no_op_node__$t;"; - say " node__$t__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) - say " node__$t__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) - for $t.list -> $c - { print " $t__$c = (fun state v continue -> "; # (*_info*) - if ($c) { - print "ignore continue; return (state , v)"; - } else { - print "continue.$c.node__$c state v"; +# 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;;"; } - say ") ;"; } - say ' }' } -say "let no_op : type state . (state,_) fold_map_config__$moduleName = \{"; -for $adts.list -> $t -{ say " $t = no_op__$t;" } -say '};;'; + for $adts.list -> $t { + if ($t eq $variant) { + for $t.list -> $c { + say " val make__$t__$c : {$c ne '' ?? "$c " !! 'unit'} -> $t;;"; + } + } elsif ($t eq $record) { + print " val make__$t"; + say ' :'; + for $t.list -> $f + { say " {$f}:{$f} ->"; } + say " $t;;"; + } else { + print " val make__$t : ("; + print $t.map({$_}).join(" , "); + say ") $t -> $t;;"; + } + } -say ""; -for $adts.list -> $t -{ say "let with__$t : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; - say "let with__$t__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; - say "let with__$t__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; - for $t.list -> $c - { say "let with__$t__$c : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } + say ""; + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + { my $ty = $t[0]; + my $tc = $typeclasses{$t}; + say " val extra_info__{$ty}__$tc : $ty extra_info__$tc;;"; } + say "end"; -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 = M.f fold__$t;;"; } -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({$_ ne $record && $_ ne $variant}).map({$_}).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 = \{"; + say " node__$t : 'state -> $t -> ('state * $t , 'err) monad ;"; + for $t.list -> $c + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'} , 'err) monad ;" } + say ' };;'; + } + + say " type ('state , 'err) _continue_fold_map__$moduleName = \{"; + for $adts.list -> $t { + say " $t : ('state , 'err) _continue_fold_map__$t ;"; + } + say ' };;'; + + say ""; + for $adts.list -> $t + { say " type ('state, 'err) fold_map_config__$t = \{"; + say " node__$t : 'state -> $t -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * $t , 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : 'state -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : 'state -> $t -> $t -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*) + for $t.list -> $c + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state, 'err) _continue_fold_map__$moduleName -> ('state * {$c || '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 : ('state, 'err) fold_map_config__$t;" } + 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 : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t, 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.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " return (state, new_x);;"; + # say ""; + for $t.list -> $c + { say " let _fold_map__$t__$c : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || '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.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + # 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 = \{"; + say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; + for $t.list -> $c + { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } + say ' };' } + say ' }'; + say ' };;'; + say ""; + + # fold_map functions : tying the knot + say ""; + for $adts.list -> $t + { say " let fold_map__$t : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> $t -> (qstate * $t,err) monad ="; + say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; + for $t.list -> $c + { say " let fold_map__$t__$c : type qstate err . (qstate,err) fold_map_config__$moduleName -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' },err) monad ="; + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } + + say ""; + for $adts.list -> $t + { + say " let no_op_node__$t : type state . state -> $t -> (state,_) _continue_fold_map__$moduleName -> (state * $t,_) monad ="; + say " fun state v continue ->"; # (*_info*) + say " match v with"; + if ($t eq $variant) { + for $t.list -> $c + { given $c { + when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , O.make__$t__$c ())"; } + default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , O.make__$t__$c v)"; } } } + } elsif ($t eq $record) { + print ' { '; + for $t.list -> $f + { print "$f; "; } + say "} ->"; + for $t.list -> $f + { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } + print " return (state , (O.make__$t"; + for $t.list -> $f + { print " ~$f"; } + say " : $t))"; + } else { + print " v -> (fold_map__$t"; + if ($t ne $record && $t ne $variant && $typeclasses{$t}) { + for $t.list -> $a + { print " O.extra_info__$a__{$typeclasses{$t}}"; } + } + print " ( "; + print ( "continue.$t.$t__$_" for $t.list ).join(", "); + say " ) state v)"; + say " >>? fun (state, x) -> return (state, O.make__$t x);;"; + } + } + + for $adts.list -> $t + { say " let no_op__$t : type state . (state,_) fold_map_config__$t = \{"; + say " node__$t = no_op_node__$t;"; + say " node__$t__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) + say " node__$t__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) + for $t.list -> $c + { print " $t__$c = (fun state v continue -> "; # (*_info*) + if ($c) { + print "ignore continue; return (state , v)"; + } else { + print "continue.$c.node__$c state v"; + } + say ") ;"; } + say ' }' } + + say " let no_op : type state . (state,_) fold_map_config__$moduleName = \{"; + for $adts.list -> $t + { say " $t = no_op__$t;" } + say ' };;'; + + say ""; + for $adts.list -> $t + { say " let with__$t : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; + say " let with__$t__pre_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; + say " let with__$t__post_state : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; + for $t.list -> $c + { say " let with__$t__$c : _ -> _ fold_map_config__$moduleName -> _ fold_map_config__$moduleName = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } + 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 = $t;;"; + } + + for $adts.list -> $t { + if ($t eq $variant) { + for $t.list -> $c { + say "let make__$t__$c : {$c ne '' ?? "$c " !! 'unit'} -> $t = fun {$c ne '' ?? 'v' !! '()'} -> $c {$c ne '' ?? 'v ' !! ''};;"; + } + } elsif ($t eq $record) { + print "let make__$t"; + print ' :'; + for $t.list -> $f + { print " {$f}:{$f} ->"; } + print " $t = fun"; + for $t.list -> $f + { print " ~{$f}"; } + print " -> \{"; + for $t.list -> $f + { print " {$f} ;"; } + say " \};;"; + } else { + print "let make__$t : ("; + print $t.map({$_}).join(" , "); + print ") $t -> $t = "; + print "fun x -> x"; + say ";;"; + } + } + + say ""; + for $adts.grep({$_ ne $record && $_ ne $variant && $typeclasses{$_}}).unique(:as({$_, $_})) -> $t + { my $ty = $t[0]; + my $tc = $typeclasses{$t}; + 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;;"; +} diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index c48ca1ac1..46b014be6 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -1,13 +1,13 @@ module BlahBluh = struct -module StringMap = Map.Make(String);; -(* generic folds for nodes *) -type 'state generic_continue_fold_node = { - continue : 'state -> 'state ; - (* generic folds for each field *) - continue_ctors_or_fields : ('state -> 'state) StringMap.t ; -};; -(* map from node names to their generic folds *) -type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; + module StringMap = Map.Make(String);; + (* generic folds for nodes *) + type 'state generic_continue_fold_node = { + continue : 'state -> 'state ; + (* generic folds for each field *) + continue_ctors_or_fields : ('state -> 'state) StringMap.t ; + };; + (* map from node names to their generic folds *) + type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;; end module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_config end) = struct diff --git a/src/test/adt_generator/.gitignore b/src/test/adt_generator/.gitignore index c1c657206..189a4ee60 100644 --- a/src/test/adt_generator/.gitignore +++ b/src/test/adt_generator/.gitignore @@ -1 +1,3 @@ /generated_fold.ml +/generated_map.ml +/generated_o.ml diff --git a/src/test/adt_generator/amodule.ml b/src/test/adt_generator/amodule.ml index ad8035380..abd5490ae 100644 --- a/src/test/adt_generator/amodule.ml +++ b/src/test/adt_generator/amodule.ml @@ -1,3 +1,4 @@ +[@@@warning "-33"] (* open Amodule_utils *) type root = diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune index 1f82e7ad0..16af71a00 100644 --- a/src/test/adt_generator/dune +++ b/src/test/adt_generator/dune @@ -1,7 +1,7 @@ (rule - (target generated_fold.ml) + (targets generated_fold.ml generated_map.ml generated_o.ml) (deps ../../../src/stages/adt_generator/generator.raku amodule.ml) - (action (with-stdout-to generated_fold.ml (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml))) + (action (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml Generated_o generated_o.ml generated_fold.ml generated_map.ml)) (mode (promote (until-clean) (only *))) ) diff --git a/src/test/adt_generator/fold.ml b/src/test/adt_generator/fold.ml index 271974820..fd817b4a3 100644 --- a/src/test/adt_generator/fold.ml +++ b/src/test/adt_generator/fold.ml @@ -1 +1,2 @@ include Generated_fold +include Generated_map.Mapper diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 484940341..4ee398516 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -2,6 +2,8 @@ open Amodule open Fold open Simple_utils.Trace +module O = Fold.O + let (|>) v f = f v module Errors = struct @@ -22,9 +24,9 @@ let () = let op = no_op |> with__a (fun state the_a (*_info*) continue_fold -> - let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in - let%bind state, 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