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

Break down the large fold_config structure into smaller structures

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-03-28 22:28:28 +01:00
parent 2991e48ce6
commit 253da1e9f5
2 changed files with 47 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -172,25 +172,35 @@ 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) ;";
say "type 'state continue_fold_map__$t<name> = \{";
say " node__$t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : {$c<type> || 'unit'} -> 'state -> ({$c<newType> || 'unit'} * 'state) ;" }
say ' }';
}
say "type 'state continue_fold_map = \{";
for $adts.list -> $t {
say " $t<name> : 'state continue_fold_map__$t<name> ;";
}
say ' }';
say "";
for $adts.list -> $t
{ say "type 'state fold_map_config__$t<name> = \{";
say " node__$t<name> : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
say " node__$t<name>__pre_state : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
say " node__$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> || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c<newType> || 'unit'} * 'state) ;";
}
say '}' }
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 ;";
for $t<ctorsOrFields>.list -> $c
{ 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 " $t<name> : 'state fold_map_config__$t<name>;" }
say ' }';
say "";
@ -295,9 +305,11 @@ 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> = \{";
say " node__$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 ' }';
say "";
@ -306,15 +318,15 @@ 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 " 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>.node__$t<name>__pre_state x (*(fun () -> whole_adt_info, info__$t<name>)*) state in";
say " let (new_x, state) = visitor.$t<name>.node__$t<name> x (*(fun () -> whole_adt_info, info__$t<name>)*) state continue_fold_map in";
say " let state = visitor.$t<name>.node__$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> || '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>.$t<name>__$c<name> x (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*) state continue_fold_map";
say ""; } }
@ -327,7 +339,7 @@ for $adts.list -> $t
say " adt = whole_adt_info () ;";
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>.node__$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
@ -341,44 +353,46 @@ for $adts.list -> $t
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>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
say ""; }
}
say "let no_op : 'a fold_map_config = \{";
for $adts.list -> $t
{ say " $t<name> = (fun v (*_info*) state continue ->";
{ say " $t<name> = \{";
say " node__$t<name> = (fun v (*_info*) state continue ->";
say " match v with";
if ($t<kind> eq $variant) {
for $t<ctorsOrFields>.list -> $c
{ 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)"; } } }
when '' { say " | $c<name> -> let ((), state) = continue.$t<name>.$t<name>__$c<name> () state in ($c<newName>, state)"; }
default { say " | $c<name> v -> let (v, state) = continue.$t<name>.$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>.$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 ( "continue.$t<name>.$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 " node__$t<name>__pre_state = (fun v (*_info*) state -> ignore v; state) ;";
say " node__$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 -> ";
if ($c<isBuiltin>) {
print "ignore continue; (v, state)";
} else {
print "continue.$c<type> v state";
print "continue.$c<type>.node__$c<type> v state";
}
say ") ;"; } }
say ") ;"; }
say ' };' }
say '}';

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

@ -7,10 +7,11 @@ 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 = 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__' ; a2__' }, state'' + 1)
a = { no_op.a with
node__a = fun the_a (*_info*) state continue_fold ->
let (a1__' , state') = continue_fold.ta1.node__ta1 the_a.a1 state in
let (a2__' , state'') = continue_fold.ta2.node__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
@ -21,7 +22,7 @@ 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 = { no_op.a with node__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
if state != 2 then
@ -31,7 +32,7 @@ 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 = { no_op.a with node__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
if state != 2 then