From b2d80e0154dded3c3ccc15452cf4c95567f800d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 20 May 2020 20:14:45 +0100 Subject: [PATCH 1/6] Rename src/stages/4-ast_typed/types.ml (part 1: does not build) --- src/stages/4-ast_typed/{types.ml => ast.ml} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/stages/4-ast_typed/{types.ml => ast.ml} (100%) diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/ast.ml similarity index 100% rename from src/stages/4-ast_typed/types.ml rename to src/stages/4-ast_typed/ast.ml 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 2/6] 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 From 92069077dffcd5d7abef15719aaab60086a4620a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 22 May 2020 02:22:35 +0100 Subject: [PATCH 3/6] Auto-generated comparator for AST_typed --- src/passes/1-parser/cameligo/Scoping.ml | 2 +- src/passes/1-parser/pascaligo/Scoping.ml | 2 +- src/stages/4-ast_typed/compare_generic.ml | 173 +++++++++++++++++++ vendors/ligo-utils/simple-utils/location.ml | 11 ++ vendors/ligo-utils/simple-utils/region.ml | 5 + vendors/ligo-utils/simple-utils/region.mli | 5 + vendors/ligo-utils/simple-utils/x_list.ml | 11 ++ vendors/ligo-utils/simple-utils/x_string.ml | 6 + vendors/ligo-utils/simple-utils/x_string.mli | 1 + 9 files changed, 214 insertions(+), 2 deletions(-) create mode 100644 src/stages/4-ast_typed/compare_generic.ml diff --git a/src/passes/1-parser/cameligo/Scoping.ml b/src/passes/1-parser/cameligo/Scoping.ml index 651306022..e1332b96d 100644 --- a/src/passes/1-parser/cameligo/Scoping.ml +++ b/src/passes/1-parser/cameligo/Scoping.ml @@ -22,7 +22,7 @@ module Ord = struct type t = AST.variable let compare v1 v2 = - compare v1.value v2.value + String.compare v1.value v2.value end module VarSet = Set.Make (Ord) diff --git a/src/passes/1-parser/pascaligo/Scoping.ml b/src/passes/1-parser/pascaligo/Scoping.ml index 64a8eea52..3fc439efb 100644 --- a/src/passes/1-parser/pascaligo/Scoping.ml +++ b/src/passes/1-parser/pascaligo/Scoping.ml @@ -23,7 +23,7 @@ module Ord = struct type t = AST.variable let compare v1 v2 = - compare v1.value v2.value + String.compare v1.value v2.value end module VarSet = Set.Make (Ord) diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml new file mode 100644 index 000000000..d69704a1f --- /dev/null +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -0,0 +1,173 @@ +open Types +open Fold + +module M = struct + type 'a lz = unit -> 'a (* Lazy values *) + type t = + | NoState + | Record of string * (string * t lz) list + | VariantConstructor of string * string * t lz + | Bool of inline + | Bytes of bytes + | Constructor' of string + | Expression_variable of expression_variable + | Int of int + | Label' of string + | Ligo_string of ligo_string + | Location of location + | Operation of packed_internal_operation + | Str of string + | Type_expression of ast_core_type_expression + | Unit of unit + | Var of type_variable + | Z of z + | List of t lz list + | Location_wrap of t lz Location.wrap + | CMap of (constructor' * t lz) list + | LMap of (label * t lz) list + | UnionFind of t lz list list + | Set of t lz list + | TypeVariableMap of (type_variable * t lz) list + + (* TODO: make these functions return a lazy stucture *) + let op : t fold_config = { + generic = (fun _state info -> + match info.node_instance.instance_kind with + | RecordInstance { fields } -> + let aux (fld : 'x Adt_info.ctor_or_field_instance) = + ( fld.cf.name , fun () -> fld.cf_continue NoState ) in + Record ("name_of_the_record", List.map aux fields) + | VariantInstance { constructor ; _ } -> + VariantConstructor ("name_of_the_variant", constructor.cf.name, fun () -> constructor.cf_continue NoState) + | PolyInstance { poly=_; arguments=_; poly_continue } -> + poly_continue NoState + ); + int = (fun _visitor _state i -> Int i ); + type_variable = (fun _visitor _state type_variable -> Var type_variable) ; + bool = (fun _visitor _state b -> Bool b) ; + z = (fun _visitor _state i -> Z i) ; + string = (fun _visitor _state str -> Str str) ; + ligo_string = (fun _visitor _state str -> Ligo_string str) ; + bytes = (fun _visitor _state bytes -> Bytes bytes) ; + unit = (fun _visitor _state () -> Unit ()) ; + packed_internal_operation = (fun _visitor _state op -> Operation op) ; + expression_variable = (fun _visitor _state ev -> Expression_variable ev) ; + constructor' = (fun _visitor _state (Constructor c) -> Constructor' c) ; + location = (fun _visitor _state loc -> Location loc) ; + label = (fun _visitor _state (Label lbl) -> Label' lbl) ; + ast_core_type_expression = (fun _visitor _state te -> Type_expression te) ; + constructor_map = (fun _visitor continue _state cmap -> + let kcmp (Constructor a, _) (Constructor b, _) = String.compare a b in + let lst = List.sort kcmp (CMap.bindings cmap) in + CMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + label_map = (fun _visitor continue _state lmap -> + let kcmp (Label a, _) (Label b, _) = String.compare a b in + let lst = List.sort kcmp (LMap.bindings lmap) in + LMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + list = (fun _visitor continue _state lst -> + (List (List.map (fun x () -> continue NoState x) lst))); + location_wrap = (fun _visitor continue _state lwrap -> + let ({ wrap_content; location } : _ Location.wrap) = lwrap in + (Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location})); + option = (fun _visitor continue _state o -> + match o with + | None -> VariantConstructor ("built-in:option", "None", fun () -> NoState) + | Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v)); + poly_unionfind = (fun _visitor continue _state p -> + (* UnionFind.Poly2.partitions returns the partitions in a + deterministic order, and the elements within a given + partition also follow a deterministic order. *) + let lst = (UnionFind.Poly2.partitions p) in + let aux l = List.map (fun x () -> continue NoState x) l in + UnionFind (List.map aux lst)); + poly_set = (fun _visitor continue _state set -> + Set (List.map (fun x () -> continue NoState x) (RedBlackTrees.PolySet.elements set))); + typeVariableMap = (fun _visitor continue _state tvmap -> + let kcmp (a, _) (b, _) = Var.compare a b in + let lst = List.sort kcmp (RedBlackTrees.PolyMap.bindings tvmap) in + TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); + } + + let serialize : (t fold_config -> t -> 'a -> t) -> 'a -> t = fun fold v -> + fold op NoState v + + (* Generate a unique tag for each case handled below. We can then + compare data by their tag and contents. *) + let tag = function + | NoState -> 0 + | Record _ -> 1 + | VariantConstructor _ -> 2 + | Bool _ -> 3 + | Bytes _ -> 4 + | Constructor' _ -> 5 + | Expression_variable _ -> 6 + | Int _ -> 7 + | Label' _ -> 8 + | Ligo_string _ -> 9 + | Location _ -> 10 + | Operation _ -> 11 + | Str _ -> 12 + | Type_expression _ -> 13 + | Unit _ -> 14 + | Var _ -> 15 + | Z _ -> 16 + | List _ -> 17 + | Location_wrap _ -> 18 + | CMap _ -> 19 + | LMap _ -> 20 + | UnionFind _ -> 21 + | Set _ -> 22 + | TypeVariableMap _ -> 23 + + let cmp2 f a1 b1 g a2 b2 = match f a1 b1 with 0 -> g a2 b2 | c -> c + let cmp3 f a1 b1 g a2 b2 h a3 b3 = match f a1 b1 with 0 -> (match g a2 b2 with 0 -> h a3 b3 | c -> c) | c -> c + let rec compare_field (na, va) (nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_cmap_entry (Constructor na, va) (Constructor nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_lmap_entry (Label na, va) (Label nb, vb) = cmp2 String.compare na nb compare_lz_t va vb + and compare_tvmap_entry (tva, va) (tvb, vb) = cmp2 Var.compare tva tvb compare_lz_t va vb + and compare_lz_t a b = compare_t (a ()) (b ()) + and compare_t (a : t) (b : t) = + match (a, b) with + | (NoState, NoState) -> failwith "Should not happen (unless for ctors with no args?)" + | (Record (a, fa), Record (b, fb)) -> cmp2 String.compare a b (List.compare ~compare:compare_field) fa fb + | (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) -> + cmp3 + String.compare va vb + String.compare ca cb + compare_lz_t xa xb + | (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b + | (Bytes a, Bytes b) -> Bytes.compare a b + | (Constructor' a, Constructor' b) -> String.compare a b + | (Expression_variable a, Expression_variable b) -> Var.compare a b + | (Int a, Int b) -> Int.compare a b + | (Label' a, Label' b) -> String.compare a b + | (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b + | (Location a, Location b) -> Location.compare a b + | (Operation a, Operation b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for packed_internal_operation ? *) + | (Str a, Str b) -> String.compare a b + | (Type_expression a, Type_expression b) -> Pervasives.compare a b (* TODO: is there a proper comparison function defined for ast_core_type_expression ? *) + | (Unit (), Unit ()) -> 0 + | (Var a, Var b) -> Var.compare a b + | (Z a, Z b) -> Z.compare a b + | (List a, List b) -> List.compare ~compare:compare_lz_t a b + | (Location_wrap a, Location_wrap b) -> Location.compare_wrap ~compare:compare_lz_t a b + | (CMap a, CMap b) -> List.compare ~compare:compare_cmap_entry a b + | (LMap a, LMap b) -> List.compare ~compare:compare_lmap_entry a b + | (UnionFind a, UnionFind b) -> List.compare ~compare:(List.compare ~compare:compare_lz_t) a b + | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b + | (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b + + | ((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a), + ((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) -> + Int.compare (tag a) (tag b) + + + let mk_compare : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a b -> + compare_t (serialize fold a) (serialize fold b) +end + +include Fold.Folds(struct + type state = M.t ;; + type 'a t = 'a -> 'a -> int ;; + let f = M.mk_compare ;; +end) diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 7087fe899..32411d072 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -17,6 +17,12 @@ let pp = fun ppf t -> | Virtual s -> Format.fprintf ppf "%s" s | File f -> Format.fprintf ppf "%s" (f#to_string `Point) +let compare a b = match a,b with + | (File a, File b) -> Region.compare a b + | (File _, Virtual _) -> -1 + | (Virtual _, File _) -> 1 + | (Virtual a, Virtual b) -> String.compare a b + let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = (* TODO: give correct unicode offsets (the random number is here so @@ -35,6 +41,11 @@ type 'a wrap = { location : t ; } +let compare_wrap ~compare:compare_content { wrap_content = wca ; location = la } { wrap_content = wcb ; location = lb } = + match compare_content wca wcb with + | 0 -> compare la lb + | c -> c + let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } let get_location x = x.location let unwrap { wrap_content ; _ } = wrap_content diff --git a/vendors/ligo-utils/simple-utils/region.ml b/vendors/ligo-utils/simple-utils/region.ml index a90c51604..dac76ec93 100644 --- a/vendors/ligo-utils/simple-utils/region.ml +++ b/vendors/ligo-utils/simple-utils/region.ml @@ -136,6 +136,11 @@ let lt r1 r2 = && Pos.lt r1#start r2#start && Pos.lt r1#stop r2#stop +let compare r1 r2 = + if equal r1 r2 then 0 + else if lt r1 r2 then -1 + else 1 + let cover r1 r2 = if r1#is_ghost then r2 diff --git a/vendors/ligo-utils/simple-utils/region.mli b/vendors/ligo-utils/simple-utils/region.mli index 378830350..415dc770d 100644 --- a/vendors/ligo-utils/simple-utils/region.mli +++ b/vendors/ligo-utils/simple-utils/region.mli @@ -135,6 +135,11 @@ val equal : t -> t -> bool [r2]. (See {! Pos.lt}.) *) val lt : t -> t -> bool +(** The call [compare r1 r2] has the value 0 if [equal r1 r2] returns + [true]. Otherwise it returns -1 if [lt r1 r2] returns [true], and 1 + if [lt r1 r2] returns [false]. *) +val compare : t -> t -> int + (** Given two regions [r1] and [r2], we may want the region [cover r1 r2] that covers [r1] and [r2]. We have the property [equal (cover r1 r2) (cover r2 r1)]. (In a sense, it is the maximum region, but diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 4b74c0261..38e48ff21 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -178,6 +178,17 @@ let rec assoc_opt ?compare:cmp x = [] -> None | (a,b)::l -> if compare a x = 0 then Some b else assoc_opt ~compare x l +let rec compare ?compare:cmp a b = + let cmp = unopt ~default:Pervasives.compare cmp in + match a,b with + [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | ha::ta, hb::tb -> + (match cmp ha hb with + 0 -> compare ta tb + | c -> c) + module Ne = struct diff --git a/vendors/ligo-utils/simple-utils/x_string.ml b/vendors/ligo-utils/simple-utils/x_string.ml index f7155375c..0f316ac26 100644 --- a/vendors/ligo-utils/simple-utils/x_string.ml +++ b/vendors/ligo-utils/simple-utils/x_string.ml @@ -6,6 +6,12 @@ let pp ppf = function Standard s -> Format.fprintf ppf "%S" s | Verbatim v -> Format.fprintf ppf "{|%s|}" v +let compare ?(compare=compare) a b = match a,b with + (Standard a, Standard b) -> compare a b + | (Standard _, Verbatim _) -> -1 + | (Verbatim _, Standard _) -> 1 + | (Verbatim a, Verbatim b) -> compare a b + let extract = function Standard s -> s | Verbatim v -> v diff --git a/vendors/ligo-utils/simple-utils/x_string.mli b/vendors/ligo-utils/simple-utils/x_string.mli index 5ded5f73f..14b8159f8 100644 --- a/vendors/ligo-utils/simple-utils/x_string.mli +++ b/vendors/ligo-utils/simple-utils/x_string.mli @@ -7,5 +7,6 @@ type t = Standard of string | Verbatim of string +val compare : ?compare:(string->string->int) -> t -> t -> int val pp : Format.formatter -> t -> unit val extract : t -> string From 008f228ed779cbd1ef38b8bc82eeafa3aae8e5fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 22 May 2020 18:19:26 +0100 Subject: [PATCH 4/6] Hide the intermediate functions from PP_generic's signature --- src/stages/4-ast_typed/PP_generic.ml | 206 ++++++++++++++------------- 1 file changed, 104 insertions(+), 102 deletions(-) diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index 502ee88fa..9ada9130e 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -3,115 +3,117 @@ open Fold open Format open PP_helpers -let needs_parens = { - generic = (fun state info -> - match info.node_instance.instance_kind with - | RecordInstance _ -> false - | VariantInstance _ -> true - | PolyInstance { poly =_; arguments=_; poly_continue } -> - (poly_continue state) - ); - type_variable = (fun _ _ _ -> true) ; - bool = (fun _ _ _ -> false) ; - int = (fun _ _ _ -> false) ; - z = (fun _ _ _ -> false) ; - string = (fun _ _ _ -> false) ; - ligo_string = (fun _ _ _ -> false) ; - bytes = (fun _ _ _ -> false) ; - unit = (fun _ _ _ -> false) ; - packed_internal_operation = (fun _ _ _ -> false) ; - expression_variable = (fun _ _ _ -> false) ; - constructor' = (fun _ _ _ -> false) ; - location = (fun _ _ _ -> false) ; - label = (fun _ _ _ -> false) ; - ast_core_type_expression = (fun _ _ _ -> true) ; - constructor_map = (fun _ _ _ _ -> false) ; - label_map = (fun _ _ _ _ -> false) ; - list = (fun _ _ _ _ -> false) ; - location_wrap = (fun _ _ _ _ -> false) ; - option = (fun _visitor _continue _state o -> - match o with None -> false | Some _ -> true) ; - poly_unionfind = (fun _ _ _ _ -> false) ; - poly_set = (fun _ _ _ _ -> false) ; - typeVariableMap = (fun _ _ _ _ -> false) ; - } +module M = struct + let needs_parens = { + generic = (fun state info -> + match info.node_instance.instance_kind with + | RecordInstance _ -> false + | VariantInstance _ -> true + | PolyInstance { poly =_; arguments=_; poly_continue } -> + (poly_continue state) + ); + type_variable = (fun _ _ _ -> true) ; + bool = (fun _ _ _ -> false) ; + int = (fun _ _ _ -> false) ; + z = (fun _ _ _ -> false) ; + string = (fun _ _ _ -> false) ; + ligo_string = (fun _ _ _ -> false) ; + bytes = (fun _ _ _ -> false) ; + unit = (fun _ _ _ -> false) ; + packed_internal_operation = (fun _ _ _ -> false) ; + expression_variable = (fun _ _ _ -> false) ; + constructor' = (fun _ _ _ -> false) ; + location = (fun _ _ _ -> false) ; + label = (fun _ _ _ -> false) ; + ast_core_type_expression = (fun _ _ _ -> true) ; + constructor_map = (fun _ _ _ _ -> false) ; + label_map = (fun _ _ _ _ -> false) ; + list = (fun _ _ _ _ -> false) ; + location_wrap = (fun _ _ _ _ -> false) ; + option = (fun _visitor _continue _state o -> + match o with None -> false | Some _ -> true) ; + poly_unionfind = (fun _ _ _ _ -> false) ; + poly_set = (fun _ _ _ _ -> false) ; + typeVariableMap = (fun _ _ _ _ -> false) ; + } -let op ppf = { - generic = (fun () info -> - match info.node_instance.instance_kind with - | RecordInstance { fields } -> - let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = - fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in - fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields - | VariantInstance { constructor ; _ } -> - if constructor.cf_new_fold needs_parens false - then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () - else let spc = if String.equal constructor.cf.type_ "" then "" else " " in - fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) () - | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue ()) - ); - int = (fun _visitor () i -> fprintf ppf "%i" i ); - type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; - bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; - z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; - string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; - ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; - bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; - unit = (fun _visitor () () -> fprintf ppf "()") ; - packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; - expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; - constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; - location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; - label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; - ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; - constructor_map = (fun _visitor continue () cmap -> - let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in - let aux ppf (Constructor k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in - fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - label_map = (fun _visitor continue () lmap -> - let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in - let aux ppf (Label k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in - fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - list = (fun _visitor continue () lst -> - let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in - fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); - location_wrap = (fun _visitor continue () lwrap -> - let ({ wrap_content; location } : _ Location.wrap) = lwrap in - fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); - (* list_ne = (fun _visitor continue () (first, lst) -> + let op ppf = { + generic = (fun () info -> + match info.node_instance.instance_kind with + | RecordInstance { fields } -> + let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = + fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in + fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields + | VariantInstance { constructor ; _ } -> + if constructor.cf_new_fold needs_parens false + then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () + else let spc = if String.equal constructor.cf.type_ "" then "" else " " in + fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) () + | PolyInstance { poly=_; arguments=_; poly_continue } -> + (poly_continue ()) + ); + int = (fun _visitor () i -> fprintf ppf "%i" i ); + type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; + bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; + z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; + string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; + ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; + bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; + unit = (fun _visitor () () -> fprintf ppf "()") ; + packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; + expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; + constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; + location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; + label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; + ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; + constructor_map = (fun _visitor continue () cmap -> + let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in + let aux ppf (Constructor k, v) = + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in + fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); + label_map = (fun _visitor continue () lmap -> + let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in + let aux ppf (Label k, v) = + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in + fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); + list = (fun _visitor continue () lst -> + let aux ppf elt = + fprintf ppf "%a" (fun _ppf -> continue ()) elt in + fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); + location_wrap = (fun _visitor continue () lwrap -> + let ({ wrap_content; location } : _ Location.wrap) = lwrap in + fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); + (* list_ne = (fun _visitor continue () (first, lst) -> let aux ppf elt = fprintf ppf "%a" (fun _ppf -> continue ()) elt in fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *) - option = (fun _visitor continue () o -> - match o with - | None -> fprintf ppf "None" - | Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; - poly_unionfind = (fun _visitor continue () p -> - let lst = (UnionFind.Poly2.partitions p) in - let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]" - (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) - (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in - let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in - fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst); - poly_set = (fun _visitor continue () set -> - let lst = (RedBlackTrees.PolySet.elements set) in - fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); - typeVariableMap = (fun _visitor continue () tvmap -> - let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in - let aux ppf (k, v) = - fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in - fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); - } + option = (fun _visitor continue () o -> + match o with + | None -> fprintf ppf "None" + | Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; + poly_unionfind = (fun _visitor continue () p -> + let lst = (UnionFind.Poly2.partitions p) in + let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]" + (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) + (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in + let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in + fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst); + poly_set = (fun _visitor continue () set -> + let lst = (RedBlackTrees.PolySet.elements set) in + fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); + typeVariableMap = (fun _visitor continue () tvmap -> + let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in + let aux ppf (k, v) = + fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in + fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); + } -let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> - fold (op ppf) () v + let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> + fold (op ppf) () v +end include Fold.Folds(struct type state = unit ;; type 'a t = formatter -> 'a -> unit ;; - let f = print ;; + let f = M.print ;; end) From ee5e484bf414db39b29389c64a93bc33b27562c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 22 May 2020 18:25:44 +0100 Subject: [PATCH 5/6] Use the auto-generated comparators as the implementations for the typeclass-like requirements for comparison functions --- src/stages/4-ast_typed/ast.ml | 3 ++- src/stages/4-ast_typed/comparable.ml | 1 + src/stages/4-ast_typed/compare_generic.ml | 18 ++++++++++++++++-- src/stages/4-ast_typed/fold.ml | 4 ++-- src/stages/adt_generator/generator.raku | 19 +++++++++++++++---- 5 files changed, 36 insertions(+), 9 deletions(-) create mode 100644 src/stages/4-ast_typed/comparable.ml diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index c9f17ac5f..e85aace9d 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -4,7 +4,8 @@ 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. *) + be specified for a given polymorphic type. The implementation is + provided by the Comparable module *) (*@ typeclass poly_unionfind comparable *) (*@ typeclass poly_set comparable *) diff --git a/src/stages/4-ast_typed/comparable.ml b/src/stages/4-ast_typed/comparable.ml new file mode 100644 index 000000000..255ed7fbe --- /dev/null +++ b/src/stages/4-ast_typed/comparable.ml @@ -0,0 +1 @@ +include Compare_generic.Comparable diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml index d69704a1f..9a4cdc413 100644 --- a/src/stages/4-ast_typed/compare_generic.ml +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -1,7 +1,8 @@ open Types -open Fold +open Generated_fold module M = struct + let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *) type 'a lz = unit -> 'a (* Lazy values *) type t = | NoState @@ -164,10 +165,23 @@ module M = struct let mk_compare : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a b -> compare_t (serialize fold a) (serialize fold b) + + let mk_comparable : (t fold_config -> t -> 'a -> t) -> 'a extra_info__comparable = fun fold -> + { compare = mk_compare fold } end -include Fold.Folds(struct +(* Generate a comparison function for each type, named like the type itself. *) +include Folds(struct type state = M.t ;; type 'a t = 'a -> 'a -> int ;; let f = M.mk_compare ;; end) + +module Comparable = struct + (* Generate a comparator typeclass-like object for each type, named like the type itself. *) + include Folds(struct + type state = M.t ;; + type 'a t = 'a extra_info__comparable ;; + let f = M.mk_comparable ;; + end) +end diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml index f1a08e4cb..cc02b5fba 100644 --- a/src/stages/4-ast_typed/fold.ml +++ b/src/stages/4-ast_typed/fold.ml @@ -1,3 +1,3 @@ include Generated_fold -module M1 = struct include Generated_map end -module M2 = struct include Generated_o end +include Generated_map +include Generated_o diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 99c5c1a56..c30e144c8 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -232,6 +232,10 @@ $*OUT = open $folder_filename, :w; # say ""; } } + # 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 " let fold__$builtin : type qstate . the_folds -> qstate fold_config -> qstate -> $builtin -> qstate = fun the_folds visitor state x ->"; + say " ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) say ""; say ' let the_folds : the_folds = {'; @@ -247,11 +251,17 @@ $*OUT = open $folder_filename, :w; { 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;;" } } + # 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 " let fold__$builtin : type qstate . qstate fold_config -> qstate -> $builtin -> qstate = fun visitor state x -> fold__$builtin 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;;"; } + # 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 " let $builtin = M.f fold__$builtin"; } say " end"; } @@ -291,8 +301,8 @@ $*OUT = open $mapper_filename, :w; 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;;"; } + my $typeclass = $typeclasses{$t}; + say " val extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass;;"; } say "end"; say ""; @@ -491,8 +501,9 @@ $*OUT = open $combinators_filename, :w; 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) \};;"; } + my $typeclass = $typeclasses{$t}; + say "let extra_info__{$ty}__$typeclass : $ty extra_info__$typeclass = {tc $typeclass}.$ty;;"; + } # Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare: say "(* Check that we won't have a cyclic module dependency when using the Folder to auto-generate the compare: *)"; say "module DummyTest_ = Generated_fold;;"; From 851132528dec8091af3acf77cf0abe5257fafbe3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 22 May 2020 19:27:10 +0100 Subject: [PATCH 6/6] auto-generated folds: have a distinct input and output type for the state --- src/stages/4-ast_typed/PP_generic.ml | 96 +++++++++++------------ src/stages/4-ast_typed/compare_generic.ml | 37 +++++---- src/stages/adt_generator/generator.raku | 41 +++++----- src/stages/adt_generator/generic.ml | 38 ++++----- src/test/adt_generator/use_a_fold.ml | 28 +++---- 5 files changed, 124 insertions(+), 116 deletions(-) diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml index 9ada9130e..1e503ace6 100644 --- a/src/stages/4-ast_typed/PP_generic.ml +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -4,14 +4,16 @@ open Format open PP_helpers module M = struct + type no_state = NoState let needs_parens = { - generic = (fun state info -> + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance _ -> false | VariantInstance _ -> true | PolyInstance { poly =_; arguments=_; poly_continue } -> - (poly_continue state) + (poly_continue NoState) ); + generic_empty_ctor = (fun _ -> false) ; type_variable = (fun _ _ _ -> true) ; bool = (fun _ _ _ -> false) ; int = (fun _ _ _ -> false) ; @@ -37,83 +39,81 @@ module M = struct typeVariableMap = (fun _ _ _ _ -> false) ; } - let op ppf = { - generic = (fun () info -> + let op ppf : (no_state, unit) fold_config = { + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance { fields } -> - let aux ppf (fld : 'x Adt_info.ctor_or_field_instance) = - fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) () in + let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) = + fprintf ppf "%s = %a" fld.cf.name (fun _ppf -> fld.cf_continue) NoState in fprintf ppf "{@,@[ %a @]@,}" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields | VariantInstance { constructor ; _ } -> - if constructor.cf_new_fold needs_parens false - then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) () + if constructor.cf_new_fold needs_parens NoState + then fprintf ppf "%s (%a)" constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState else let spc = if String.equal constructor.cf.type_ "" then "" else " " in - fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) () + fprintf ppf "%s%s%a" constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue ()) + (poly_continue NoState) ); - int = (fun _visitor () i -> fprintf ppf "%i" i ); - type_variable = (fun _visitor () type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; - bool = (fun _visitor () b -> fprintf ppf "%s" (if b then "true" else "false")) ; - z = (fun _visitor () i -> fprintf ppf "%a" Z.pp_print i) ; - string = (fun _visitor () str -> fprintf ppf "\"%s\"" str) ; - ligo_string = (fun _visitor () str -> fprintf ppf "%a" Ligo_string.pp str) ; - bytes = (fun _visitor () _bytes -> fprintf ppf "bytes...") ; - unit = (fun _visitor () () -> fprintf ppf "()") ; - packed_internal_operation = (fun _visitor () _op -> fprintf ppf "Operation(...bytes)") ; - expression_variable = (fun _visitor () ev -> fprintf ppf "%a" Var.pp ev) ; - constructor' = (fun _visitor () (Constructor c) -> fprintf ppf "Constructor %s" c) ; - location = (fun _visitor () loc -> fprintf ppf "%a" Location.pp loc) ; - label = (fun _visitor () (Label lbl) -> fprintf ppf "Label %s" lbl) ; - ast_core_type_expression = (fun _visitor () te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; - constructor_map = (fun _visitor continue () cmap -> + generic_empty_ctor = (fun NoState -> ()) ; + int = (fun _visitor NoState i -> fprintf ppf "%i" i ); + type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" Var.pp type_variable) ; + bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ; + z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ; + string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ; + ligo_string = (fun _visitor NoState str -> fprintf ppf "%a" Ligo_string.pp str) ; + bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ; + unit = (fun _visitor NoState () -> fprintf ppf "()") ; + packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ; + expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ; + constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ; + location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ; + label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ; + ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" Ast_core.PP.type_expression te) ; + constructor_map = (fun _visitor continue NoState cmap -> let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in let aux ppf (Constructor k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in fprintf ppf "CMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - label_map = (fun _visitor continue () lmap -> + label_map = (fun _visitor continue NoState lmap -> let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in let aux ppf (Label k, v) = - fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue ()) v in + fprintf ppf "(Constructor %s, %a)" k (fun _ppf -> continue NoState) v in fprintf ppf "LMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); - list = (fun _visitor continue () lst -> + list = (fun _visitor continue NoState lst -> let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in + fprintf ppf "%a" (fun _ppf -> continue NoState) elt in fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); - location_wrap = (fun _visitor continue () lwrap -> + location_wrap = (fun _visitor continue NoState lwrap -> let ({ wrap_content; location } : _ Location.wrap) = lwrap in - fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue ()) wrap_content Location.pp location); - (* list_ne = (fun _visitor continue () (first, lst) -> - let aux ppf elt = - fprintf ppf "%a" (fun _ppf -> continue ()) elt in - fprintf ppf "[@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) (first::lst)); *) - option = (fun _visitor continue () o -> + fprintf ppf "{ wrap_content = %a ; location = %a }" (fun _ppf -> continue NoState) wrap_content Location.pp location); + option = (fun _visitor continue NoState o -> match o with | None -> fprintf ppf "None" - | Some v -> fprintf ppf "%a" (fun _ppf -> continue ()) v) ; - poly_unionfind = (fun _visitor continue () p -> + | Some v -> fprintf ppf "%a" (fun _ppf -> continue NoState) v) ; + poly_unionfind = (fun _visitor continue NoState p -> let lst = (UnionFind.Poly2.partitions p) in let aux1 l = fprintf ppf "[@,@[ (*%a*) %a @]@,]" - (fun _ppf -> continue ()) (UnionFind.Poly2.repr (List.hd l) p) - (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) l in + (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p) + (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) l in let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " ;@ ") in fprintf ppf "UnionFind [@,@[ %a @]@,]" aux2 lst); - poly_set = (fun _visitor continue () set -> + poly_set = (fun _visitor continue NoState set -> let lst = (RedBlackTrees.PolySet.elements set) in - fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue ()) (fun ppf () -> fprintf ppf " ;@ ")) lst); - typeVariableMap = (fun _visitor continue () tvmap -> + fprintf ppf "Set [@,@[ %a @]@,]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " ;@ ")) lst); + typeVariableMap = (fun _visitor continue NoState tvmap -> let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in let aux ppf (k, v) = - fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue ()) v in + fprintf ppf "(Var %a, %a)" Var.pp k (fun _ppf -> continue NoState) v in fprintf ppf "typeVariableMap [@,@[ %a @]@,]" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) lst); } - let print : (unit fold_config -> unit -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> - fold (op ppf) () v + let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> + fold (op ppf) NoState v end include Fold.Folds(struct - type state = unit ;; + type in_state = M.no_state ;; + type out_state = unit ;; type 'a t = formatter -> 'a -> unit ;; let f = M.print ;; end) diff --git a/src/stages/4-ast_typed/compare_generic.ml b/src/stages/4-ast_typed/compare_generic.ml index 9a4cdc413..e630f1e3a 100644 --- a/src/stages/4-ast_typed/compare_generic.ml +++ b/src/stages/4-ast_typed/compare_generic.ml @@ -5,7 +5,7 @@ module M = struct let compare = () (* Hide Pervasives.compare to avoid calling it without explicit qualification. *) type 'a lz = unit -> 'a (* Lazy values *) type t = - | NoState + | EmptyCtor | Record of string * (string * t lz) list | VariantConstructor of string * string * t lz | Bool of inline @@ -30,12 +30,14 @@ module M = struct | Set of t lz list | TypeVariableMap of (type_variable * t lz) list + type no_state = NoState + (* TODO: make these functions return a lazy stucture *) - let op : t fold_config = { - generic = (fun _state info -> + let op : (no_state, t) fold_config = { + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance { fields } -> - let aux (fld : 'x Adt_info.ctor_or_field_instance) = + let aux (fld : ('xi, 'xo) Adt_info.ctor_or_field_instance) = ( fld.cf.name , fun () -> fld.cf_continue NoState ) in Record ("name_of_the_record", List.map aux fields) | VariantInstance { constructor ; _ } -> @@ -43,6 +45,7 @@ module M = struct | PolyInstance { poly=_; arguments=_; poly_continue } -> poly_continue NoState ); + generic_empty_ctor = (fun NoState -> EmptyCtor) ; int = (fun _visitor _state i -> Int i ); type_variable = (fun _visitor _state type_variable -> Var type_variable) ; bool = (fun _visitor _state b -> Bool b) ; @@ -72,7 +75,7 @@ module M = struct (Location_wrap { wrap_content = (fun () -> continue NoState wrap_content) ; location})); option = (fun _visitor continue _state o -> match o with - | None -> VariantConstructor ("built-in:option", "None", fun () -> NoState) + | None -> VariantConstructor ("built-in:option", "None", fun () -> EmptyCtor) | Some v -> VariantConstructor ("built-in:option", "Some", fun () -> continue NoState v)); poly_unionfind = (fun _visitor continue _state p -> (* UnionFind.Poly2.partitions returns the partitions in a @@ -89,13 +92,17 @@ module M = struct TypeVariableMap (List.map (fun (k, v) -> (k, fun () -> continue NoState v)) lst)); } - let serialize : (t fold_config -> t -> 'a -> t) -> 'a -> t = fun fold v -> + let serialize : ((no_state, t) fold_config -> no_state -> 'a -> t) -> 'a -> t = fun fold v -> fold op NoState v + (* What follows should be roughly the same for all ASTs, so it + should be easy to share a single copy of that and of the t type + definition above. *) + (* Generate a unique tag for each case handled below. We can then compare data by their tag and contents. *) let tag = function - | NoState -> 0 + | EmptyCtor -> 0 | Record _ -> 1 | VariantConstructor _ -> 2 | Bool _ -> 3 @@ -129,7 +136,7 @@ module M = struct and compare_lz_t a b = compare_t (a ()) (b ()) and compare_t (a : t) (b : t) = match (a, b) with - | (NoState, NoState) -> failwith "Should not happen (unless for ctors with no args?)" + | (EmptyCtor, EmptyCtor) -> failwith "Should not happen (unless for ctors with no args?)" | (Record (a, fa), Record (b, fb)) -> cmp2 String.compare a b (List.compare ~compare:compare_field) fa fb | (VariantConstructor (va, ca, xa), VariantConstructor (vb, cb, xb)) -> cmp3 @@ -158,21 +165,22 @@ module M = struct | (Set a, Set b) -> List.compare ~compare:compare_lz_t a b | (TypeVariableMap a, TypeVariableMap b) -> List.compare ~compare:compare_tvmap_entry a b - | ((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a), - ((NoState | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) -> + | ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as a), + ((EmptyCtor | Record _ | VariantConstructor _ | Bool _ | Bytes _ | Constructor' _ | Expression_variable _ | Int _ | Label' _ | Ligo_string _ | Location _ | Operation _ | Str _ | Type_expression _ | Unit _ | Var _ | Z _ | List _ | Location_wrap _ | CMap _ | LMap _ | UnionFind _ | Set _ | TypeVariableMap _) as b) -> Int.compare (tag a) (tag b) - let mk_compare : (t fold_config -> t -> 'a -> t) -> 'a -> 'a -> int = fun fold a b -> + let mk_compare : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a -> 'a -> int = fun fold a b -> compare_t (serialize fold a) (serialize fold b) - let mk_comparable : (t fold_config -> t -> 'a -> t) -> 'a extra_info__comparable = fun fold -> + let mk_comparable : ((no_state , t) fold_config -> no_state -> 'a -> t) -> 'a extra_info__comparable = fun fold -> { compare = mk_compare fold } end (* Generate a comparison function for each type, named like the type itself. *) include Folds(struct - type state = M.t ;; + type in_state = M.no_state ;; + type out_state = M.t ;; type 'a t = 'a -> 'a -> int ;; let f = M.mk_compare ;; end) @@ -180,7 +188,8 @@ end) module Comparable = struct (* Generate a comparator typeclass-like object for each type, named like the type itself. *) include Folds(struct - type state = M.t ;; + type in_state = M.no_state ;; + type out_state = M.t ;; type 'a t = 'a extra_info__comparable ;; let f = M.mk_comparable ;; end) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index c30e144c8..aa5de686b 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -96,29 +96,30 @@ $*OUT = open $folder_filename, :w; 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;"; + say " type ('in_state, 'out_state , 'adt_info_node_instance_info) _fold_config = \{"; + say " generic : 'in_state -> 'adt_info_node_instance_info -> 'out_state;"; + say " generic_empty_ctor : 'in_state -> 'out_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;"; } + { say " $builtin : ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> 'in_state -> $builtin -> 'out_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 " $poly : 'a . ('in_state , 'out_state , 'adt_info_node_instance_info) _fold_config -> ('in_state -> 'a -> 'out_state) -> 'in_state -> 'a $poly -> 'out_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 " type nonrec ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config = ('in_state , 'out_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 " type ('in_state, 'out_state) fold_config = ('in_state , 'out_state , ('in_state , 'out_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;"; + { say " fold__$t : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> $t -> 'out_state;"; for $t.list -> $c - { say " fold__$t__$c : 'state . the_folds -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } + { say " fold__$t__$c : 'in_state 'out_state . the_folds -> ('in_state , 'out_state) fold_config -> 'in_state -> { $c || 'unit' } -> 'out_state;"; } } say ' };;'; # generic programming info about the nodes and fields @@ -132,7 +133,7 @@ $*OUT = open $folder_filename, :w; 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 " let continue_info__$t__$c : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> {$c || 'unit'} -> (in_qstate, out_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);"; @@ -154,7 +155,7 @@ $*OUT = open $folder_filename, :w; 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 " let continue_info__$t : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> $t -> (in_qstate , out_qstate) Adt_info.instance = fun the_folds visitor x ->"; say ' {'; say " instance_declaration_name = \"$t\";"; do given $t { @@ -208,9 +209,9 @@ $*OUT = open $folder_filename, :w; # 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 ->"; + { say " let fold__$t : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $t -> out_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 ' let node_instance_info : (in_qstate , out_qstate) Adt_info.node_instance_info = {'; say " adt = whole_adt_info () ;"; say " node_instance = continue_info__$t the_folds visitor x"; say ' } in'; @@ -218,11 +219,11 @@ $*OUT = open $folder_filename, :w; 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"; + { say " let fold__$t__$c : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> { $c || 'unit' } -> out_qstate = fun the_folds visitor state { $c ?? 'x' !! '()' } ->"; + # say " let ctor_or_field_instance_info : (in_qstate , out_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;;"; + say " ignore the_folds; visitor.generic_empty_ctor state;;"; } elsif ($c) { say " ignore the_folds; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } else { @@ -234,7 +235,7 @@ $*OUT = open $folder_filename, :w; } # 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 " let fold__$builtin : type qstate . the_folds -> qstate fold_config -> qstate -> $builtin -> qstate = fun the_folds visitor state x ->"; + { say " let fold__$builtin : type in_qstate out_qstate . the_folds -> (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun the_folds visitor state x ->"; say " ignore the_folds; visitor.$builtin visitor state x;;"; } # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) say ""; @@ -248,15 +249,15 @@ $*OUT = open $folder_filename, :w; # 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;;"; + { say " let fold__$t : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $t -> out_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 " let fold__$t__$c : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> { $c || 'unit' } -> out_qstate = fun visitor state x -> fold__$t__$c the_folds visitor state x;;" } } # 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 " let fold__$builtin : type qstate . qstate fold_config -> qstate -> $builtin -> qstate = fun visitor state x -> fold__$builtin the_folds visitor state x;;"; } + { say " let fold__$builtin : type in_qstate out_qstate . (in_qstate , out_qstate) fold_config -> in_qstate -> $builtin -> out_qstate = fun visitor state x -> fold__$builtin 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"; + say " module Folds (M : sig type in_state type out_state type 'a t val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_state) -> 'a t end) = struct"; for $adts.list -> $t { say " let $t = M.f fold__$t;;"; } # look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '') diff --git a/src/stages/adt_generator/generic.ml b/src/stages/adt_generator/generic.ml index 46b014be6..f1ad0fcb8 100644 --- a/src/stages/adt_generator/generic.ml +++ b/src/stages/adt_generator/generic.ml @@ -10,35 +10,35 @@ module BlahBluh = struct 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 +module Adt_info (M : sig type ('in_state , 'out_state , 'adt_info_node_instance_info) fold_config end) = struct type kind = | Record | Variant | Poly of string - type 'state record_instance = { - fields : 'state ctor_or_field_instance list; + type ('in_state , 'out_state) record_instance = { + fields : ('in_state , 'out_state) ctor_or_field_instance list; } - and 'state constructor_instance = { - constructor : 'state ctor_or_field_instance ; + and ('in_state , 'out_state) constructor_instance = { + constructor : ('in_state , 'out_state) ctor_or_field_instance ; variant : ctor_or_field list } - and 'state poly_instance = { + and ('in_state , 'out_state) poly_instance = { poly : string; arguments : string list; - poly_continue : 'state -> 'state + poly_continue : 'in_state -> 'out_state } - and 'state kind_instance = - | RecordInstance of 'state record_instance - | VariantInstance of 'state constructor_instance - | PolyInstance of 'state poly_instance + and ('in_state , 'out_state) kind_instance = + | RecordInstance of ('in_state , 'out_state) record_instance + | VariantInstance of ('in_state , 'out_state) constructor_instance + | PolyInstance of ('in_state , 'out_state) poly_instance - and 'state instance = { + and ('in_state , 'out_state) instance = { instance_declaration_name : string; - instance_kind : 'state kind_instance; + instance_kind : ('in_state , 'out_state) kind_instance; } and ctor_or_field = @@ -48,11 +48,11 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi type_ : string; } - and 'state ctor_or_field_instance = + and ('in_state , 'out_state) ctor_or_field_instance = { cf : ctor_or_field; - cf_continue : 'state -> 'state; - cf_new_fold : 'state . ('state, ('state node_instance_info)) M.fold_config -> 'state -> 'state; + cf_continue : 'in_state -> 'out_state; + cf_new_fold : 'in_state 'out_state . ('in_state , 'out_state , (('in_state , 'out_state) node_instance_info)) M.fold_config -> 'in_state -> 'out_state; } and node = @@ -64,9 +64,9 @@ module Adt_info (M : sig type ('state , 'adt_info_node_instance_info) fold_confi (* TODO: rename things a bit in this file. *) and adt = node list - and 'state node_instance_info = { + and ('in_state , 'out_state) node_instance_info = { adt : adt ; - node_instance : 'state instance ; + node_instance : ('in_state , 'out_state) instance ; } - and 'state ctor_or_field_instance_info = adt * node * 'state ctor_or_field_instance + and ('in_state , 'out_state) ctor_or_field_instance_info = adt * node * ('in_state , 'out_state) ctor_or_field_instance end diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 4ee398516..e6277f76e 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -63,35 +63,33 @@ let () = let _noi : (int, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) let _nob : (bool, [> error]) fold_map_config__Amodule = no_op (* (fun _ -> ()) *) +type no_state = NoState let () = let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in - let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in - let nostate = false, "" in - let op = { - generic = (fun state info -> - assert_nostate state; + let op : ('i, 'o) Generated_fold.fold_config = { + generic = (fun NoState info -> match info.node_instance.instance_kind with | RecordInstance { fields } -> - false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }" + false, "{ " ^ String.concat " ; " (List.map (fun (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue NoState)) fields) ^ " }" | VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue; cf_new_fold=_ }; variant=_ } -> - (match cf_continue nostate with + (match cf_continue NoState with | true, arg -> true, name ^ " (" ^ arg ^ ")" | false, arg -> true, name ^ " " ^ arg) | PolyInstance { poly=_; arguments=_; poly_continue } -> - (poly_continue nostate) + (poly_continue NoState) ) ; - string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ; - unit = (fun _visitor state () -> assert_nostate state; false , "()") ; - int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ; - list = (fun _visitor continue state lst -> - assert_nostate state; - false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ; + generic_empty_ctor = (fun NoState -> false, "") ; + string = (fun _visitor NoState str -> false , "\"" ^ str ^ "\"") ; + unit = (fun _visitor NoState () -> false , "()") ; + int = (fun _visitor NoState i -> false , string_of_int i) ; + list = (fun _visitor continue NoState lst -> + false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue NoState) lst) ^ " ]") ; (* generic_ctor_or_field = (fun _info state -> * match _info () with * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * ); *) } in - let (_ , state) = fold__root op nostate some_root in + let (_ , state) = Generated_fold.fold__root op NoState some_root in let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in if String.equal state expected; then ()