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

Generic fold example: OCaml printer for an arbitrary ADT

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-03-13 15:34:43 +01:00
parent a49f0806c0
commit 12aec6edd0
4 changed files with 228 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/stages/adt_generator/amodule_utils.ml
View File

@ -1,10 +1,10 @@
let fold_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_option v state continue =
let fold_map_option v state continue =
match v with
Some x -> continue x state
| None -> None

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

@ -133,6 +133,7 @@ say "(* This is an auto-generated file. Do not edit. *)";
say "";
say "open $moduleName";
say "open {$moduleName}_utils";
say "module Adt_info = Generic.Adt_info";
say "";
for $adts.kv -> $index, $t {
@ -156,34 +157,7 @@ for $adts.kv -> $index, $t {
}
say "";
say "module Adt_info = struct";
say " type kind =";
say " | Record";
say " | Variant";
say " | Poly of string";
say "";
say " type ctor_or_field =";
say ' {';
say " name : string;";
say " isBuiltin : bool;";
say " type_ : string;";
say ' }';
say "";
say " type node =";
say ' {';
say " kind : kind;";
say " name : string;";
say " ctors_or_fields : ctor_or_field list;";
say ' }';
say "";
say " type adt = node list";
say " type node_info = unit -> adt * node";
say " type ctor_or_field_info = unit -> adt * node * ctor_or_field";
say "end";
say "";
say "type 'state continue_fold =";
say "type 'state continue_fold_map =";
say ' {';
for $adts.list -> $t
{ say " $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
@ -192,28 +166,63 @@ for $adts.list -> $t
say ' }';
say "";
say "type 'state fold_config =";
say "type 'state fold_map_config =";
say ' {';
for $adts.list -> $t
{ say " $t<name> : $t<name> -> Adt_info.node_info -> 'state -> ('state continue_fold) -> ($t<newName> * 'state) ;";
say " $t<name>_pre_state : $t<name> -> Adt_info.node_info -> 'state -> 'state ;";
say " $t<name>_post_state : $t<name> -> $t<newName> -> Adt_info.node_info -> 'state -> 'state ;";
{ say " $t<name> : $t<name> -> (*Adt_info.node_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
say " $t<name>_pre_state : $t<name> -> (*Adt_info.node_info ->*) 'state -> 'state ;";
say " $t<name>_post_state : $t<name> -> $t<newName> -> (*Adt_info.node_info ->*) 'state -> 'state ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>_$c<name> : $c<type> -> Adt_info.ctor_or_field_info -> 'state -> ('state continue_fold) -> ($c<newType> * 'state) ;";
{ say " $t<name>_$c<name> : $c<type> -> (*Adt_info.ctor_or_field_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
} }
say ' }';
say "";
say "module StringMap = Map.Make(String)";
say "(* generic folds for nodes *)";
say "type 'state generic_continue_fold_node = \{";
say " continue : 'state -> 'state ;";
say " (* generic folds for each field *)";
say " continue_ctors_or_fields : ('state -> 'state) StringMap.t ;";
say '}';
say "(* map from node names to their generic folds *)";
say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t";
say "";
say "type 'state fold_config =";
say ' {';
say " generic : 'state Adt_info.node_info -> 'state -> 'state;";
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin>}).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;"; }
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> ; "; }
say "]";
# generic programming info about the nodes and fields
say "";
for $adts.list -> $t
{ for $t<ctorsOrFields>.list -> $c
{ say "(* info for field or ctor $t<name>.$c<name> *)";
say "let 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 " isBuiltin = {$c<isBuiltin> ?? 'true' !! 'false'};";
say " type_ = \"$c<type>\";";
say '}';
say "";
# TODO: factor out some of the common bits here.
say "and continue_info_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate Adt_info.ctor_or_field_continue = fun visitor x -> \{";
say " name = \"$c<name>\";";
say " isBuiltin = {$c<isBuiltin> ?? 'true' !! 'false'};";
say " type_ = \"$c<type>\";";
say " continue = fun state -> fold_$t<name>_$c<name> visitor x state;";
say '}';
say ""; }
say "(* info for node $t<name> *)";
say "let 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" }
@ -225,42 +234,103 @@ for $adts.list -> $t
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 ->";
do given $t<kind> {
when $record {
say 'Record {';
say " name = \"$t<name>\";";
print " fields = [ ";
for $t<ctorsOrFields>.list -> $c { print "continue_info_$t<name>_$c<name> visitor x.$c<name> ; "; }
say "];";
say '}';
}
when $variant {
say 'Variant {';
say " name = \"$t<name>\";";
say " constructor = (match x with";
for $t<ctorsOrFields>.list -> $c { say " | $c<name> v -> continue_info_$t<name>_$c<name> visitor v"; }
say " );";
print " variant = [ ";
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
say "];";
say '}'
}
default {
say 'Poly {';
say " name = \"$t<name>\";";
say " type_ = \"$_\";";
print " arguments = [";
# TODO: sort by c<name> (currently we only have one-argument
# polymorphic types so it happens to work but should be fixed.
for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
say "];";
print " continue = (fun state -> visitor.$_ visitor x (";
print $t<ctorsOrFields>
.map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).continue state)" })
.join(", ");
say ") state);";
say '}';
}
};
say ""; }
say "(* info for adt $moduleName *)";
print "let whole_adt_info : Adt_info.adt = [ ";
for $adts.list -> $t
{ print "info_$t<name> ; "; }
say "]";
# make the "continue" object
say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->";
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_$t<name> visitor ;";
{ say " $t<name> = fold_map_$t<name> visitor ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>_$c<name> = fold_$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_$t<name> : type state . state fold_config -> $t<name> -> state -> ($t<newName> * state) = fun visitor x state ->";
say " let continue_fold : state continue_fold = mk_continue_fold 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 in";
say " let state = visitor.$t<name>_post_state x new_x (fun () -> whole_adt_info, info_$t<name>) state in";
{ 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 " (new_x, state)";
say "";
for $t<ctorsOrFields>.list -> $c
{ say "and fold_$t<name>_$c<name> : type state . state fold_config -> $c<type> -> state -> ($c<newType> * state) = fun visitor x state ->";
say " let continue_fold : state continue_fold = mk_continue_fold visitor in";
say " visitor.$t<name>_$c<name> x (fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>) state continue_fold";
{ 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 " 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 ""; } }
say "let no_op : 'a fold_config = \{";
# fold functions
say "";
for $adts.list -> $t
{ say " $t<name> = (fun v _info state continue ->";
{ 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_info : qstate Adt_info.node_info = fun () -> whole_adt_info (), continue_info_$t<name> visitor x in";
# say " let (new_x, state) = visitor.$t<name> x (fun () -> whole_adt_info, info_$t<name>) state continue_fold in";
say " let state = visitor.generic node_info state in";
say " 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_info : qstate Adt_info.ctor_or_field_info = fun () -> whole_adt_info (), info_$t<name>, continue_info_$t<name>_$c<name> visitor x in";
if ($c<isBuiltin>) {
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_info*) visitor.$c<type> visitor x state in";
} else {
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_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 ""; }
}
say "let no_op : 'a fold_map_config = \{";
for $adts.list -> $t
{ say " $t<name> = (fun v (*_info*) state continue ->";
say " match v with";
if ($t<kind> eq $variant) {
for $t<ctorsOrFields>.list -> $c
@ -277,15 +347,15 @@ for $adts.list -> $t
{ print "$f<newName>; "; }
say '}, state)';
} else {
print " v -> fold_$t<kind> v state ( ";
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 {

54
src/stages/adt_generator/generic.ml Normal file
View File

@ -0,0 +1,54 @@
[@@@warning "-30"]
module Adt_info = struct
type kind =
| Record
| Variant
| Poly of string
type 'state record_instance = {
name : string;
fields : 'state ctor_or_field_continue list;
}
and 'state constructor_instance = {
name : string;
constructor : 'state ctor_or_field_continue ;
variant : ctor_or_field list
}
and 'state poly_instance = {
name : string;
type_ : string;
arguments : string list;
continue : 'state -> 'state
}
and 'state instance =
| Record of 'state record_instance
| Variant of 'state constructor_instance
| Poly of 'state poly_instance
and ctor_or_field =
{
name : string;
isBuiltin : bool;
type_ : string;
}
and 'state ctor_or_field_continue =
{
name : string;
isBuiltin : bool;
type_ : string;
continue : 'state -> 'state
}
type node =
{
kind : kind;
name : string;
ctors_or_fields : ctor_or_field list;
}
(* TODO: rename things a bit in this file. *)
type adt = node list
type 'state node_info = unit -> adt * 'state instance
type 'state ctor_or_field_info = unit -> adt * node * 'state ctor_or_field_continue
end

53
src/stages/adt_generator/use_a_fold.ml
View File

@ -7,7 +7,7 @@ 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 ->
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
({
@ -16,7 +16,7 @@ let () =
}, state'' + 1)
} in
let state = 0 in
let (_, state) = fold_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 +24,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_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,15 +34,50 @@ 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_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
()
(* Test that the same fold_config can be ascibed with different 'a type arguments *)
let _noi : int fold_config = no_op (* (fun _ -> ()) *)
let _nob : bool fold_config = no_op (* (fun _ -> ()) *)
(* Test that the same fold_map_config can be ascibed with different 'a type arguments *)
let _noi : int fold_map_config = no_op (* (fun _ -> ()) *)
let _nob : bool fold_map_config = no_op (* (fun _ -> ()) *)
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 info state ->
assert_nostate state;
match info () with
| (_, Adt_info.Record { name=_; fields }) ->
false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_continue) -> fld.name ^ " = " ^ snd (fld.continue nostate)) fields) ^ " }"
| (_, Adt_info.Variant { name=_; constructor={ name; isBuiltin=_; type_=_; continue }; variant=_ }) ->
(match continue nostate with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)
| (_, Adt_info.Poly { name=_; type_=_; arguments=_; continue }) ->
(continue nostate)
);
string = (fun _visitor str state -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor () state -> assert_nostate state; false , "()") ;
int = (fun _visitor i state -> assert_nostate state; false , string_of_int i) ;
list = (fun _visitor lst continue state ->
assert_nostate state;
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 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
()
else
failwith (Printf.sprintf "Test failed: expected\n %s\n but got\n %s" expected state)