WIP on making the AST compatibile with the ADT generator
This commit is contained in:
Suzanne Dupéron
parent
ba9441a134
commit
9639c2f775
@ -880,7 +880,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
||||
let%bind (ex' , state') = type_expression e state matchee in
|
||||
let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in
|
||||
let tvs =
|
||||
let aux (cur : O.matching_content) =
|
||||
let aux (cur : O.matching_expr) =
|
||||
match cur with
|
||||
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
|
||||
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
|
||||
|
||||
@ -284,7 +284,7 @@ and expression_content ppf (ec: expression_content) =
|
||||
and assoc_expression ppf : map_kv -> unit =
|
||||
fun {k ; v} -> fprintf ppf "%a -> %a" expression k expression v
|
||||
|
||||
and single_record_patch ppf ((p, expr) : label * expr) =
|
||||
and single_record_patch ppf ((p, expr) : label * expression) =
|
||||
fprintf ppf "%a <- %a" label p expression expr
|
||||
|
||||
|
||||
@ -298,7 +298,7 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c
|
||||
fun f ppf {constructor=c; pattern; body} ->
|
||||
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
|
||||
|
||||
and matching : (formatter -> expression -> unit) -> _ -> matching_content -> unit = fun f ppf m -> match m with
|
||||
and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with
|
||||
| Match_tuple {vars; body; tvs=_} ->
|
||||
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
|
||||
| Match_variant {cases ; tv=_} ->
|
||||
|
||||
@ -126,7 +126,7 @@ val e_chain_id : string -> expression_content
|
||||
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content
|
||||
val e_lambda : lambda -> expression_content
|
||||
val e_pair : expression -> expression -> expression_content
|
||||
val e_application : expression -> expr -> expression_content
|
||||
val e_application : expression -> expression -> expression_content
|
||||
val e_variable : expression_variable -> expression_content
|
||||
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
|
||||
|
||||
|
||||
@ -1,9 +1,9 @@
|
||||
; (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)))
|
||||
; ; (mode (promote (until-clean)))
|
||||
; )
|
||||
(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)))
|
||||
; (mode (promote (until-clean)))
|
||||
)
|
||||
|
||||
(library
|
||||
(name ast_typed)
|
||||
@ -13,6 +13,7 @@
|
||||
tezos-utils
|
||||
ast_core ; Is that a good idea?
|
||||
stage_common
|
||||
adt_generator
|
||||
)
|
||||
(preprocess
|
||||
(pps ppx_let bisect_ppx --conditional)
|
||||
|
||||
@ -232,7 +232,7 @@ module Free_variables = struct
|
||||
and matching_variant_case : (bindings -> expression -> bindings) -> bindings -> matching_content_case -> bindings = fun f b { constructor=_ ; pattern ; body } ->
|
||||
f (union (singleton pattern) b) body
|
||||
|
||||
and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> bindings = fun f b m ->
|
||||
and matching : (bindings -> expression -> bindings) -> bindings -> matching_expr -> bindings = fun f b m ->
|
||||
match m with
|
||||
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
|
||||
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
|
||||
|
||||
@ -89,7 +89,7 @@ module Captured_variables = struct
|
||||
and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
|
||||
f (union (singleton pattern) b) body
|
||||
|
||||
and matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m ->
|
||||
and matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result = fun f b m ->
|
||||
match m with
|
||||
| Match_bool { match_true = t ; match_false = fa } ->
|
||||
let%bind t' = f b t in
|
||||
|
||||
@ -6,7 +6,7 @@ val program_to_main : program -> string -> lambda result
|
||||
module Captured_variables : sig
|
||||
|
||||
type bindings = expression_variable list
|
||||
val matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result
|
||||
val matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result
|
||||
|
||||
val matching_expression : bindings -> matching_expr -> bindings result
|
||||
|
||||
|
||||
@ -19,9 +19,12 @@ type type_constant =
|
||||
| TC_timestamp
|
||||
| TC_void
|
||||
|
||||
type type_content =
|
||||
| T_sum of type_expression constructor_map
|
||||
| T_record of type_expression label_map
|
||||
type te_cmap = type_expression constructor_map
|
||||
and te_lmap = type_expression label_map
|
||||
|
||||
and type_content =
|
||||
| T_sum of te_cmap
|
||||
| T_record of te_lmap
|
||||
| T_arrow of arrow
|
||||
| T_variable of type_variable
|
||||
| T_constant of type_constant
|
||||
@ -29,7 +32,7 @@ type type_content =
|
||||
|
||||
and arrow = {
|
||||
type1: type_expression;
|
||||
type2: type_expression
|
||||
type2: type_expression;
|
||||
}
|
||||
|
||||
and type_map_args = {
|
||||
@ -56,7 +59,7 @@ and type_operator =
|
||||
|
||||
and type_expression = {
|
||||
type_content: type_content;
|
||||
type_meta: type_meta
|
||||
type_meta: type_meta;
|
||||
}
|
||||
|
||||
type literal =
|
||||
@ -74,7 +77,7 @@ type literal =
|
||||
| Literal_key_hash of string
|
||||
| Literal_chain_id of string
|
||||
| Literal_void
|
||||
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||
| Literal_operation of packed_internal_operation
|
||||
|
||||
type matching_content_bool = {
|
||||
match_true : expression ;
|
||||
@ -104,10 +107,13 @@ and matching_content_option = {
|
||||
match_some : matching_content_some ;
|
||||
}
|
||||
|
||||
and expression_variable_list = expression_variable list
|
||||
and type_expression_list = type_expression list
|
||||
|
||||
and matching_content_tuple = {
|
||||
vars : expression_variable list ;
|
||||
vars : expression_variable_list ;
|
||||
body : expression ;
|
||||
tvs : type_expression list ;
|
||||
tvs : type_expression_list ;
|
||||
}
|
||||
|
||||
and matching_content_case = {
|
||||
@ -115,12 +121,15 @@ and matching_content_case = {
|
||||
pattern : expression_variable ;
|
||||
body : expression ;
|
||||
}
|
||||
|
||||
and matching_content_case_list = matching_content_case list
|
||||
|
||||
and matching_content_variant = {
|
||||
cases: matching_content_case list;
|
||||
cases: matching_content_case_list;
|
||||
tv: type_expression;
|
||||
}
|
||||
|
||||
and matching_content =
|
||||
and matching_expr =
|
||||
| Match_bool of matching_content_bool
|
||||
| Match_list of matching_content_list
|
||||
| Match_option of matching_content_option
|
||||
@ -242,14 +251,14 @@ and constant' =
|
||||
| C_SET_DELEGATE
|
||||
| C_CREATE_CONTRACT
|
||||
|
||||
and program = declaration Location.wrap list
|
||||
and declaration_loc = declaration location_wrap
|
||||
|
||||
and inline = bool
|
||||
and program = declaration_loc list
|
||||
|
||||
and declaration_constant = {
|
||||
binder : expression_variable ;
|
||||
expr : expression ;
|
||||
inline : inline ;
|
||||
inline : bool ;
|
||||
post_env : full_environment ;
|
||||
}
|
||||
|
||||
@ -268,7 +277,7 @@ and declaration =
|
||||
|
||||
and expression = {
|
||||
expression_content: expression_content ;
|
||||
location: Location.t ;
|
||||
location: location ;
|
||||
type_expression: type_expression ;
|
||||
environment: full_environment ;
|
||||
}
|
||||
@ -283,6 +292,9 @@ and look_up = {
|
||||
ind : expression;
|
||||
}
|
||||
|
||||
and expression_label_map = expression label_map
|
||||
and map_kv_list = map_kv list
|
||||
and expression_list = expression list
|
||||
|
||||
and expression_content =
|
||||
(* Base *)
|
||||
@ -297,13 +309,14 @@ and expression_content =
|
||||
| E_constructor of constructor (* For user defined constructors *)
|
||||
| E_matching of matching
|
||||
(* Record *)
|
||||
| E_record of expression label_map
|
||||
| E_record of expression_label_map
|
||||
| E_record_accessor of record_accessor
|
||||
| E_record_update of record_update
|
||||
|
||||
and constant =
|
||||
{ cons_name: constant'
|
||||
; arguments: expression list }
|
||||
and constant = {
|
||||
cons_name: constant' ;
|
||||
arguments: expression_list ;
|
||||
}
|
||||
|
||||
and application = {
|
||||
lamb: expression ;
|
||||
@ -321,7 +334,7 @@ and let_in = {
|
||||
let_binder: expression_variable ;
|
||||
rhs: expression ;
|
||||
let_result: expression ;
|
||||
inline : inline ;
|
||||
inline : bool ;
|
||||
}
|
||||
|
||||
and recursive = {
|
||||
@ -346,10 +359,9 @@ and record_update = {
|
||||
update: expression ;
|
||||
}
|
||||
|
||||
and matching_expr = matching_content
|
||||
and matching =
|
||||
{ matchee: expression
|
||||
; cases: matching_expr
|
||||
and matching = {
|
||||
matchee: expression ;
|
||||
cases: matching_expr ;
|
||||
}
|
||||
|
||||
and ascription = {
|
||||
@ -394,13 +406,10 @@ and small_environment = {
|
||||
type_environment: type_environment ;
|
||||
}
|
||||
|
||||
and full_environment = small_environment List.Ne.t
|
||||
|
||||
and expr = expression
|
||||
|
||||
and texpr = type_expression
|
||||
and full_environment = small_environment list_ne
|
||||
|
||||
and named_type_content = {
|
||||
type_name : type_variable;
|
||||
type_value : type_expression;
|
||||
}
|
||||
|
||||
|
||||
@ -21,3 +21,22 @@ module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) =
|
||||
type 'a label_map = 'a LMap.t
|
||||
type 'a constructor_map = 'a CMap.t
|
||||
type type_meta = S.type_expression option
|
||||
|
||||
type 'a location_wrap = 'a Location.wrap
|
||||
type 'a list_ne = 'a List.Ne.t
|
||||
type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||
type location = Location.t
|
||||
type inline = bool
|
||||
|
||||
let fold_map__constructor_map : 'a . 'a constructor_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a constructor_map * 'state = fun _ _ _ -> failwith "TODO fold_map__constructor_map"
|
||||
|
||||
let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = fun _ _ _ -> failwith "TODO fold_map__label_map"
|
||||
|
||||
let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = fun l state f ->
|
||||
let aux (state, l) element = let (new_element, state) = f element state in (state, new_element::l) in
|
||||
let (state, l) = List.fold_left aux (state, []) l in
|
||||
(l, state)
|
||||
|
||||
let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap"
|
||||
|
||||
let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap"
|
||||
|
||||
@ -16,22 +16,26 @@ my $statements = $l.grep($statement_re);
|
||||
$l = $l.grep(none $statement_re);
|
||||
$statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, ''));
|
||||
$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
|
||||
$l = $l.join("\n").subst(/\n+/, "\n").split(/\nand\s+/).grep(/./);
|
||||
# TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose.
|
||||
$l = $l.join("\n").subst(/\n+/, "\n", :g); # join lines and remove consecutive newlines
|
||||
$l = $l.subst(/\s*\(\* ( <-[\*]> | \*+<-[\*\)]> )* \*\)/, '', :g); # discard comments (incl. multi-line comments)
|
||||
$l = $l.split(/\nand\s+/).grep(/./); # split lines again and preserve nonempty lines
|
||||
$l = $l.map(*.split("\n"));
|
||||
$l = $l.map: {
|
||||
my $ll = $_;
|
||||
my ($name, $kind) = do given $_[0] {
|
||||
when /^(\w+)\s*\=$/ { "$/[0]", $variant }
|
||||
when /^(\w+)\s*\=\s*\{$/ { "$/[0]", $record }
|
||||
when /^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ { "$/[0]", poly("$/[2]") }
|
||||
when /^((\w|\')+)\s*\=$/ { "$/[0]", $variant }
|
||||
when /^((\w|\')+)\s*\=\s*\{$/ { "$/[0]", $record }
|
||||
when /^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ { "$/[0]", poly("$/[2]") }
|
||||
default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
|
||||
};
|
||||
my $ctorsOrFields = do {
|
||||
when (/^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
|
||||
when (/^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
|
||||
default {
|
||||
$_[1..*].grep({ ! /^\}?$/ }).map: {
|
||||
when /^\|\s*(\w+)\s*of\s+((\'|\w)+)$/ { "$/[0]", "$/[1]" }
|
||||
when /^(\w+)\s*\:\s*((\'|\w)+)\s*\;$/ { "$/[0]", "$/[1]" }
|
||||
when /^\|\s*((\w|\')+)\s*of\s+((\w|\')+)$/ { "$/[0]", "$/[1]" }
|
||||
when /^\|\s*((\w|\')+)$/ { "$/[0]", "" }
|
||||
when /^((\w|\')+)\s*\:\s*((\w|\')+)\s*\;$/ { "$/[0]", "$/[1]" }
|
||||
default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
|
||||
}
|
||||
};
|
||||
@ -114,16 +118,16 @@ $l = $l.map: {
|
||||
my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
|
||||
{
|
||||
"name" => $name ,
|
||||
"newName" => "$name'" ,
|
||||
"newName" => "{$name}__'" ,
|
||||
"kind" => $kind ,
|
||||
"ctorsOrFields" => @(map -> ($cf, $type) {
|
||||
my $isBuiltin = ! $l.cache.first({ $_<name> eq $type });
|
||||
my $isBuiltin = (! $type) || (! $l.cache.first({ $_<name> eq $type }));
|
||||
{
|
||||
name => $cf ,
|
||||
newName => "$cf'" ,
|
||||
newName => "{$cf}__'" ,
|
||||
isBuiltin => $isBuiltin ,
|
||||
type => $type ,
|
||||
newType => $isBuiltin ?? $type !! "$type'"
|
||||
newType => $isBuiltin ?? "$type" !! "{$type}__'"
|
||||
}
|
||||
}, @ctorsOrFields),
|
||||
}
|
||||
@ -147,8 +151,12 @@ for $adts.kv -> $index, $t {
|
||||
my $typeOrAnd = $index == 0 ?? "type" !! "and";
|
||||
say "$typeOrAnd $t<newName> =";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " | $c<newName> of $c<newType>" }
|
||||
for $t<ctorsOrFields>.list -> $c {
|
||||
given $c<type> {
|
||||
when '' { say " | $c<newName>" }
|
||||
default { say " | $c<newName> of $c<newType>" }
|
||||
}
|
||||
}
|
||||
} elsif ($t<kind> eq $record) {
|
||||
say ' {';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
@ -166,10 +174,11 @@ for $adts.kv -> $index, $t {
|
||||
say "";
|
||||
say "type 'state continue_fold_map =";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
|
||||
for $adts.list -> $t {
|
||||
say " $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>_$c<name> : $c<type> -> 'state -> ($c<newType> * 'state) ;" } }
|
||||
{ say " $t<name>__$c<name> : {$c<type> || 'unit'} -> 'state -> ({$c<newType> || 'unit'} * 'state) ;" }
|
||||
}
|
||||
say ' }';
|
||||
|
||||
say "";
|
||||
@ -177,10 +186,10 @@ say "type 'state fold_map_config =";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
|
||||
say " $t<name>_pre_state : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
|
||||
say " $t<name>_post_state : $t<name> -> $t<newName> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
|
||||
say " $t<name>__pre_state : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
|
||||
say " $t<name>__post_state : $t<name> -> $t<newName> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>_$c<name> : $c<type> -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
|
||||
{ say " $t<name>__$c<name> : {$c<type> || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c<newType> || 'unit'} * 'state) ;";
|
||||
} }
|
||||
say ' }';
|
||||
|
||||
@ -198,7 +207,7 @@ say "";
|
||||
say "type 'state fold_config =";
|
||||
say ' {';
|
||||
say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;";
|
||||
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin>}).map({$_<type>}).unique -> $builtin
|
||||
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
|
||||
{ say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; }
|
||||
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $builtin
|
||||
{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; }
|
||||
@ -206,7 +215,7 @@ say ' }';
|
||||
say "(* info for adt $moduleName *)";
|
||||
print "let rec whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
|
||||
for $adts.list -> $t
|
||||
{ print "info_$t<name> ; "; }
|
||||
{ print "info__$t<name> ; "; }
|
||||
say "]";
|
||||
|
||||
# generic programming info about the nodes and fields
|
||||
@ -214,19 +223,19 @@ say "";
|
||||
for $adts.list -> $t
|
||||
{ for $t<ctorsOrFields>.list -> $c
|
||||
{ say "(* info for field or ctor $t<name>.$c<name> *)";
|
||||
say "and info_$t<name>_$c<name> : Adt_info.ctor_or_field = \{";
|
||||
say "and info__$t<name>__$c<name> : Adt_info.ctor_or_field = \{";
|
||||
say " name = \"$c<name>\";";
|
||||
say " is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
|
||||
say " type_ = \"$c<type>\";";
|
||||
say '}';
|
||||
say "";
|
||||
say "and continue_info_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{";
|
||||
say " cf = info_$t<name>_$c<name>;";
|
||||
say " cf_continue = fun state -> fold_$t<name>_$c<name> visitor x state;";
|
||||
say "and continue_info__$t<name>__$c<name> : type qstate . qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{";
|
||||
say " cf = info__$t<name>__$c<name>;";
|
||||
say " cf_continue = fun state -> fold__$t<name>__$c<name> visitor x state;";
|
||||
say '}';
|
||||
say ""; }
|
||||
say "(* info for node $t<name> *)";
|
||||
say "and info_$t<name> : Adt_info.node = \{";
|
||||
say "and info__$t<name> : Adt_info.node = \{";
|
||||
my $kind = do given $t<kind> {
|
||||
when $record { "Record" }
|
||||
when $variant { "Variant" }
|
||||
@ -235,29 +244,29 @@ for $adts.list -> $t
|
||||
say " kind = $kind;";
|
||||
say " declaration_name = \"$t<name>\";";
|
||||
print " ctors_or_fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say '}';
|
||||
say "";
|
||||
# TODO: factor out some of the common bits here.
|
||||
say "and continue_info_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun visitor x ->";
|
||||
say "and continue_info__$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun visitor x ->";
|
||||
say '{';
|
||||
say " instance_declaration_name = \"$t<name>\";";
|
||||
do given $t<kind> {
|
||||
when $record {
|
||||
say ' instance_kind = RecordInstance {';
|
||||
print " fields = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "continue_info_$t<name>_$c<name> visitor x.$c<name> ; "; }
|
||||
for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> visitor x.$c<name> ; "; }
|
||||
say " ];";
|
||||
say '};';
|
||||
}
|
||||
when $variant {
|
||||
say ' instance_kind = VariantInstance {';
|
||||
say " constructor = (match x with";
|
||||
for $t<ctorsOrFields>.list -> $c { say " | $c<name> v -> continue_info_$t<name>_$c<name> visitor v"; }
|
||||
for $t<ctorsOrFields>.list -> $c { say " | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> visitor { $c<type> ?? 'v' !! '()' }"; }
|
||||
say " );";
|
||||
print " variant = [ ";
|
||||
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
|
||||
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
|
||||
say "];";
|
||||
say '};';
|
||||
}
|
||||
@ -271,7 +280,7 @@ for $adts.list -> $t
|
||||
say "];";
|
||||
print " poly_continue = (fun state -> visitor.$_ visitor x (";
|
||||
print $t<ctorsOrFields>
|
||||
.map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).cf_continue state)" })
|
||||
.map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> visitor x).cf_continue state)" })
|
||||
.join(", ");
|
||||
say ") state);";
|
||||
say '};';
|
||||
@ -286,51 +295,53 @@ say '(* Curries the "visitor" argument to the folds (non-customizable traversal
|
||||
say "and mk_continue_fold_map : type qstate . qstate fold_map_config -> qstate continue_fold_map = fun visitor ->";
|
||||
say ' {';
|
||||
for $adts.list -> $t
|
||||
{ say " $t<name> = fold_map_$t<name> visitor ;";
|
||||
{ say " $t<name> = fold_map__$t<name> visitor ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " $t<name>_$c<name> = fold_map_$t<name>_$c<name> visitor ;"; } }
|
||||
{ say " $t<name>__$c<name> = fold_map__$t<name>__$c<name> visitor ;"; } }
|
||||
say ' }';
|
||||
say "";
|
||||
|
||||
# fold_map functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "and fold_map_$t<name> : type qstate . qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun visitor x state ->";
|
||||
{ say "and fold_map__$t<name> : type qstate . qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun visitor x state ->";
|
||||
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
|
||||
say " let state = visitor.$t<name>_pre_state x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
|
||||
say " let (new_x, state) = visitor.$t<name> x (*(fun () -> whole_adt_info, info_$t<name>)*) state continue_fold_map in";
|
||||
say " let state = visitor.$t<name>_post_state x new_x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
|
||||
say " let state = visitor.$t<name>__pre_state x (*(fun () -> whole_adt_info, info__$t<name>)*) state in";
|
||||
say " let (new_x, state) = visitor.$t<name> x (*(fun () -> whole_adt_info, info__$t<name>)*) state continue_fold_map in";
|
||||
say " let state = visitor.$t<name>__post_state x new_x (*(fun () -> whole_adt_info, info__$t<name>)*) state in";
|
||||
say " (new_x, state)";
|
||||
say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "and fold_map_$t<name>_$c<name> : type qstate . qstate fold_map_config -> $c<type> -> qstate -> ($c<newType> * qstate) = fun visitor x state ->";
|
||||
{ say "and fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> { $c<type> || 'unit' } -> qstate -> ({ $c<newType> || 'unit' } * qstate) = fun visitor x state ->";
|
||||
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
|
||||
say " visitor.$t<name>_$c<name> x (*(fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>)*) state continue_fold_map";
|
||||
say " visitor.$t<name>__$c<name> x (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*) state continue_fold_map";
|
||||
say ""; } }
|
||||
|
||||
|
||||
# fold functions
|
||||
say "";
|
||||
for $adts.list -> $t
|
||||
{ say "and fold_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate -> qstate = fun visitor x state ->";
|
||||
{ say "and fold__$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate -> qstate = fun visitor x state ->";
|
||||
# TODO: add a non-generic continue_fold.
|
||||
say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
|
||||
say " adt = whole_adt_info () ;";
|
||||
say " node_instance = continue_info_$t<name> visitor x";
|
||||
say " node_instance = continue_info__$t<name> visitor x";
|
||||
say ' } in';
|
||||
# say " let (new_x, state) = visitor.$t<name> x (fun () -> whole_adt_info, info_$t<name>) state continue_fold in";
|
||||
# say " let (new_x, state) = visitor.$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
|
||||
say " visitor.generic node_instance_info state";
|
||||
say "";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say "and fold_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate -> qstate = fun visitor x state ->";
|
||||
# say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info_$t<name>, continue_info_$t<name>_$c<name> visitor x in";
|
||||
if ($c<isBuiltin>) {
|
||||
{ say "and fold__$t<name>__$c<name> : type qstate . qstate fold_config -> { $c<type> || 'unit' } -> qstate -> qstate = fun { $c<type> ?? 'visitor x' !! '_visitor ()' } state ->";
|
||||
# say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
|
||||
if ($c<type> eq '') {
|
||||
# nothing to do, this constructor has no arguments.
|
||||
} elsif ($c<isBuiltin>) {
|
||||
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c<type> visitor x state in";
|
||||
} else {
|
||||
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold_$c<type> visitor x state in";
|
||||
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold__$c<type> visitor x state in";
|
||||
}
|
||||
say " state";
|
||||
# say " visitor.$t<name>_$c<name> x (fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>) state continue_fold";
|
||||
# say " visitor.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
|
||||
say ""; }
|
||||
}
|
||||
|
||||
@ -340,28 +351,30 @@ for $adts.list -> $t
|
||||
say " match v with";
|
||||
if ($t<kind> eq $variant) {
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ say " | $c<name> v -> let (v, state) = continue.$t<name>_$c<name> v state in ($c<newName> v, state)"; }
|
||||
{ given $c<type> {
|
||||
when '' { say " | $c<name> -> let ((), state) = continue.$t<name>__$c<name> () state in ($c<newName>, state)"; }
|
||||
default { say " | $c<name> v -> let (v, state) = continue.$t<name>__$c<name> v state in ($c<newName> v, state)"; } } }
|
||||
} elsif ($t<kind> eq $record) {
|
||||
print ' { ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<name>; "; }
|
||||
say "} ->";
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ say " let ($f<newName>, state) = continue.$t<name>_$f<name> $f<name> state in"; }
|
||||
{ say " let ($f<newName>, state) = continue.$t<name>__$f<name> $f<name> state in"; }
|
||||
print ' ({ ';
|
||||
for $t<ctorsOrFields>.list -> $f
|
||||
{ print "$f<newName>; "; }
|
||||
say '}, state)';
|
||||
} else {
|
||||
print " v -> fold_map_$t<kind> v state ( ";
|
||||
print ( "continue.$t<name>_$_<name>" for $t<ctorsOrFields>.list ).join(", ");
|
||||
print " v -> fold_map__$t<kind> v state ( ";
|
||||
print ( "continue.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
|
||||
say " )";
|
||||
}
|
||||
say " );";
|
||||
say " $t<name>_pre_state = (fun v (*_info*) state -> ignore v; state) ;";
|
||||
say " $t<name>_post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;";
|
||||
say " $t<name>__pre_state = (fun v (*_info*) state -> ignore v; state) ;";
|
||||
say " $t<name>__post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;";
|
||||
for $t<ctorsOrFields>.list -> $c
|
||||
{ print " $t<name>_$c<name> = (fun v (*_info*) state continue -> ";
|
||||
{ print " $t<name>__$c<name> = (fun v (*_info*) state continue -> ";
|
||||
if ($c<isBuiltin>) {
|
||||
print "ignore continue; (v, state)";
|
||||
} else {
|
||||
|
||||
@ -1,10 +1,10 @@
|
||||
let fold_map_list v state continue =
|
||||
let fold_map__list v state continue =
|
||||
let aux = fun (lst', state) elt ->
|
||||
let (elt', state) = continue elt state in
|
||||
(elt' :: lst' , state) in
|
||||
List.fold_left aux ([], state) v
|
||||
|
||||
let fold_map_option v state continue =
|
||||
let fold_map__option v state continue =
|
||||
match v with
|
||||
Some x -> continue x state
|
||||
| None -> None
|
||||
|
||||
@ -8,15 +8,12 @@ let () =
|
||||
let op = {
|
||||
no_op with
|
||||
a = fun the_a (*_info*) state continue_fold ->
|
||||
let (a1' , state') = continue_fold.ta1 the_a.a1 state in
|
||||
let (a2' , state'') = continue_fold.ta2 the_a.a2 state' in
|
||||
({
|
||||
a1' = a1' ;
|
||||
a2' = a2' ;
|
||||
}, state'' + 1)
|
||||
let (a1__' , state') = continue_fold.ta1 the_a.a1 state in
|
||||
let (a2__' , state'') = continue_fold.ta2 the_a.a2 state' in
|
||||
({ a1__' ; a2__' }, state'' + 1)
|
||||
} in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
let (_, state) = fold_map__root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
@ -24,9 +21,9 @@ let () =
|
||||
|
||||
let () =
|
||||
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
|
||||
let op = { no_op with a_pre_state = fun _the_a (*_info*) state -> state + 1 } in
|
||||
let op = { no_op with a__pre_state = fun _the_a (*_info*) state -> state + 1 } in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
let (_, state) = fold_map__root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
@ -34,9 +31,9 @@ let () =
|
||||
|
||||
let () =
|
||||
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
|
||||
let op = { no_op with a_post_state = fun _the_a _new_a (*_info*) state -> state + 1 } in
|
||||
let op = { no_op with a__post_state = fun _the_a _new_a (*_info*) state -> state + 1 } in
|
||||
let state = 0 in
|
||||
let (_, state) = fold_map_root op some_root state in
|
||||
let (_, state) = fold_map__root op some_root state in
|
||||
if state != 2 then
|
||||
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
|
||||
else
|
||||
@ -75,7 +72,7 @@ let () =
|
||||
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
|
||||
* ); *)
|
||||
} in
|
||||
let (_ , state) = fold_root op some_root nostate in
|
||||
let (_ , state) = fold__root op some_root nostate 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
|
||||
()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user