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

Adt generator: split structure into smaller structures; use the monad; reordered function, state and value arguments to match the order of List.fold_left.

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-04-01 16:14:43 +02:00
parent 1e1728e5dd
commit ded76b41d6
7 changed files with 205 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/stages/4-ast_typed/PP_generic.ml Normal file
View File

@ -0,0 +1,42 @@
open Types
open Fold
open Format
let print_program : formatter -> program -> unit = fun ppf p ->
ignore ppf ;
let assert_nostate _ = () in (* (needs_parens, state) = assert (not needs_parens && match state with None -> true | Some _ -> false) in *)
let nostate = false, "" in
let op = {
generic = (fun state info ->
assert_nostate state;
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) ^ " }"
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
(match cf_continue nostate with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate)
);
type_variable = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
type_meta = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
bool = (fun _visitor state b -> assert_nostate state; false , if b then "true" else "false") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
bytes = (fun _visitor state bytes -> assert_nostate state; false , (ignore bytes;"TODO:BYTES")) ;
packed_internal_operation = (fun _visitor state op -> assert_nostate state; false , (ignore op;"TODO:PACKED_INTERNAL_OPERATION")) ;
expression_variable = (fun _visitor state ev -> assert_nostate state; false , (ignore ev;"TODO:EXPRESSION_VARIABLE")) ;
constructor' = (fun _visitor state c -> assert_nostate state; false , (ignore c;"TODO:CONSTRUCTOR'")) ;
location = (fun _visitor state loc -> assert_nostate state; false , (ignore loc;"TODO:LOCATION'")) ;
label = (fun _visitor state (Label lbl) -> assert_nostate state; true, "Label " ^ lbl) ;
constructor_map = (fun _visitor continue state cmap -> assert_nostate state; false , (ignore (continue,cmap);"TODO:constructor_map")) ;
label_map = (fun _visitor continue state lmap -> assert_nostate state; false , (ignore (continue,lmap);"TODO:label_map")) ;
list = (fun _visitor continue state lst ->
assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
location_wrap = (fun _visitor continue state lwrap -> assert_nostate state; false , (ignore (continue,lwrap);"TODO:location_wrap")) ;
list_ne = (fun _visitor continue state list_ne -> assert_nostate state; false , (ignore (continue,list_ne);"TODO:location_wrap")) ;
} in
let (_ , state) = fold__program op nostate p in
Printf.printf "%s" state

1
src/stages/4-ast_typed/fold.ml Normal file
View File

@ -0,0 +1 @@
include Generated_fold

62
src/stages/4-ast_typed/types_utils.ml
View File

@ -1,4 +1,5 @@
module S = Ast_core module S = Ast_core
open Simple_utils.Trace
(* include Stage_common.Types *) (* include Stage_common.Types *)
(* type expression_ (* type expression_
@ -28,32 +29,43 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe
type location = Location.t type location = Location.t
type inline = bool type inline = bool
let fold_map__constructor_map : type a new_a state . a constructor_map -> state -> (a -> state -> new_a * state) -> new_a constructor_map * state = 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 m state f -> fun f state m ->
let aux k v (state , m) = let (new_v , state) = f v state in (state , CMap.add k new_v m) in let aux k v acc =
let (state , m) = CMap.fold aux m (state, CMap.empty) in let%bind (state , m) = acc in
(m , state) let%bind (state , new_v) = f state v in
ok (state , CMap.add k new_v m) in
let%bind (state , m) = CMap.fold aux m (ok (state, CMap.empty)) in
ok (state , m)
let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = let fold_map__label_map : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a label_map -> (state * new_a label_map) result =
fun m state f -> fun f state m ->
let aux k v (state , m) = let (new_v , state) = f v state in (state , LMap.add k new_v m) in let aux k v acc =
let (state , m) = LMap.fold aux m (state, LMap.empty) in let%bind (state , m) = acc in
(m , state) let%bind (state , new_v) = f state v in
ok (state , LMap.add k new_v m) in
let%bind (state , m) = LMap.fold aux m (ok (state, LMap.empty)) in
ok (state , m)
let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = let fold_map__list : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list -> (state * new_a list) Simple_utils.Trace.result =
fun l state f -> fun f state l ->
let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in let aux acc element =
let (state , l) = List.fold_left aux (state , []) l in let%bind state , l = acc in
(l , state) let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
ok (state , l)
let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = let fold_map__location_wrap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a location_wrap -> (state * new_a location_wrap) Simple_utils.Trace.result =
fun { wrap_content ; location } state f -> fun f state { wrap_content ; location } ->
let (state , wrap_content) = f wrap_content state in let%bind ( state , wrap_content ) = f state wrap_content in
({ wrap_content ; location }, state) ok (state , ({ wrap_content ; location } : new_a location_wrap))
let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = let fold_map__list_ne : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list_ne -> (state * new_a list_ne) Simple_utils.Trace.result =
fun (first , l) state f -> fun f state (first , l) ->
let (new_first , state) = f first state in let%bind (state , new_first) = f state first in
let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in let aux acc element =
let (state , l) = List.fold_left aux (state , []) l in let%bind state , l = acc in
((new_first , l), state) let%bind (state , new_element) = f state element in
ok (state , new_element :: l) in
let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
ok (state , (new_first , l))

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

@ -143,9 +143,17 @@ say "";
for $statements -> $statement { for $statements -> $statement {
say "$statement" say "$statement"
} }
say "type 'a monad = 'a Simple_utils.Trace.result";
say "let (>>?) v f = Simple_utils.Trace.bind f v";
say "let return v = Simple_utils.Trace.ok v";
say "open $moduleName"; say "open $moduleName";
say "module Adt_info = Adt_generator.Generic.Adt_info"; say "module Adt_info = Adt_generator.Generic.Adt_info";
say "";
say "(* must be provided by one of the open or include statements: *)";
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly"; }
say ""; say "";
for $adts.kv -> $index, $t { for $adts.kv -> $index, $t {
my $typeOrAnd = $index == 0 ?? "type" !! "and"; my $typeOrAnd = $index == 0 ?? "type" !! "and";
@ -174,9 +182,9 @@ for $adts.kv -> $index, $t {
say ""; say "";
for $adts.list -> $t { for $adts.list -> $t {
say "type 'state continue_fold_map__$t<name> = \{"; say "type 'state continue_fold_map__$t<name> = \{";
say " node__$t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;"; say " node__$t<name> : 'state -> $t<name> -> ('state * $t<newName>) monad ;";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : {$c<type> || 'unit'} -> 'state -> ({$c<newType> || 'unit'} * 'state) ;" } { say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'}) monad ;" }
say ' }'; say ' }';
} }
@ -189,11 +197,11 @@ say ' }';
say ""; say "";
for $adts.list -> $t for $adts.list -> $t
{ say "type 'state fold_map_config__$t<name> = \{"; { say "type 'state fold_map_config__$t<name> = \{";
say " node__$t<name> : $t<name> -> 'state -> 'state continue_fold_map -> ($t<newName> * 'state) ;"; # (*Adt_info.node_instance_info ->*) say " node__$t<name> : 'state -> $t<name> -> 'state continue_fold_map -> ('state * $t<newName>) monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__pre_state : $t<name> -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) say " node__$t<name>__pre_state : 'state -> $t<name> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__post_state : $t<name> -> $t<newName> -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) say " node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : {$c<type> || 'unit'} -> 'state -> 'state continue_fold_map -> ({$c<newType> || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) { say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> 'state continue_fold_map -> ('state * {$c<newType> || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
} }
say '}' } say '}' }
@ -216,19 +224,21 @@ say "type 'state generic_continue_fold = ('state generic_continue_fold_node) Str
say ""; say "";
say "type 'state fold_config ="; say "type 'state fold_config =";
say ' {'; say ' {';
say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;"; say " generic : 'state -> '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({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
{ say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; } { say " $builtin : 'state fold_config -> 'state -> $builtin -> 'state;"; }
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $builtin # look for built-in polymorphic types
{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; } for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
say ' }'; say ' }';
say ""; say "";
say 'type blahblah = {'; say 'type blahblah = {';
for $adts.list -> $t for $adts.list -> $t
{ say " fold__$t<name> : 'state . blahblah -> 'state fold_config -> $t<name> -> 'state -> 'state;"; { say " fold__$t<name> : 'state . blahblah -> 'state fold_config -> 'state -> $t<name> -> 'state;";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say " fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> { $c<type> || 'unit' } -> 'state -> 'state;"; } } { say " fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
say '}'; say '}';
# generic programming info about the nodes and fields # generic programming info about the nodes and fields
@ -244,7 +254,7 @@ for $adts.list -> $t
say ""; say "";
say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
say " cf = info__$t<name>__$c<name>;"; say " cf = info__$t<name>__$c<name>;";
say " cf_continue = fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor x state;"; say " cf_continue = fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x;";
say '}'; say '}';
say ""; } say ""; }
say "(* info for node $t<name> *)"; say "(* info for node $t<name> *)";
@ -291,11 +301,11 @@ for $adts.list -> $t
# polymorphic types so it happens to work but should be fixed. # polymorphic types so it happens to work but should be fixed.
for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; } for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
say "];"; say "];";
print " poly_continue = (fun state -> visitor.$_ visitor x ("; print " poly_continue = (fun state -> visitor.$_ visitor (";
print $t<ctorsOrFields> print $t<ctorsOrFields>
.map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> blahblah visitor x).cf_continue state)" }) .map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> blahblah visitor x).cf_continue state)" })
.join(", "); .join(", ");
say ") state);"; say ") state x);";
say '};'; say '};';
} }
}; };
@ -312,25 +322,25 @@ say "]";
# fold functions # fold functions
say ""; say "";
for $adts.list -> $t for $adts.list -> $t
{ say "let fold__$t<name> : type qstate . blahblah -> qstate fold_config -> $t<name> -> qstate -> qstate = fun blahblah visitor x state ->"; { say "let fold__$t<name> : type qstate . blahblah -> qstate fold_config -> qstate -> $t<name> -> qstate = fun blahblah visitor state x ->";
# TODO: add a non-generic continue_fold. # TODO: add a non-generic continue_fold.
say ' let node_instance_info : qstate Adt_info.node_instance_info = {'; say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
say " adt = whole_adt_info () ;"; say " adt = whole_adt_info () ;";
say " node_instance = continue_info__$t<name> blahblah visitor x"; say " node_instance = continue_info__$t<name> blahblah visitor x";
say ' } in'; say ' } 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 " let (state, new_x) = 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 " visitor.generic state node_instance_info";
say ""; say "";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> { $c<type> || 'unit' } -> qstate -> qstate = fun blahblah { $c<type> ?? 'visitor x' !! '_visitor ()' } state ->"; { say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun blahblah { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
# 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"; # 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 '') { if ($c<type> eq '') {
# nothing to do, this constructor has no arguments. # nothing to do, this constructor has no arguments.
say " state"; say " ignore blahblah; state";
} elsif ($c<isBuiltin>) { } elsif ($c<isBuiltin>) {
say " ignore blahblah; visitor.$c<type> visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) say " ignore blahblah; visitor.$c<type> visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
} else { } else {
say " blahblah.fold__$c<type> blahblah visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) say " blahblah.fold__$c<type> blahblah visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
} }
# 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 " 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 ""; }
@ -344,11 +354,12 @@ for $adts.list -> $t
{ say " fold__$t<name>__$c<name>;" } } { say " fold__$t<name>__$c<name>;" } }
say '}'; say '}';
# Tying the knot
say ""; say "";
for $adts.list -> $t for $adts.list -> $t
{ say "let fold__$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate -> qstate = fun visitor x state -> fold__$t<name> blahblah visitor x state"; { say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah visitor state x";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> { $c<type> || 'unit' } -> qstate -> qstate = fun visitor x state -> fold__$t<name>__$c<name> blahblah visitor x state" } } { say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> blahblah visitor state x" } }
say ""; say "";
@ -360,29 +371,29 @@ say '}';
# fold_map functions # fold_map functions
say ""; say "";
for $adts.list -> $t for $adts.list -> $t
{ say "let _fold_map__$t<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun mk_continue_fold_map visitor x state ->"; { say "let _fold_map__$t<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " let state = visitor.$t<name>.node__$t<name>__pre_state x state in"; # (*(fun () -> whole_adt_info, info__$t<name>)*) say " visitor.$t<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " let (new_x, state) = visitor.$t<name>.node__$t<name> x state continue_fold_map in"; # (*(fun () -> whole_adt_info, info__$t<name>)*) say " visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " let state = visitor.$t<name>.node__$t<name>__post_state x new_x state in"; # (*(fun () -> whole_adt_info, info__$t<name>)*) say " visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " (new_x, state)"; say " return (state, new_x)";
say ""; say "";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say "let _fold_map__$t<name>__$c<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> { $c<type> || 'unit' } -> qstate -> ({ $c<newType> || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; { say "let _fold_map__$t<name>__$c<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " visitor.$t<name>.$t<name>__$c<name> x state continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*) say " visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
say ""; } } say ""; } }
# make the "continue" object # make the "continue" object
say ""; say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "let mk_continue_fold_map : 'stateX . 'stateX mk_continue_fold_map = \{ fn = fun self visitor ->"; say "let mk_continue_fold_map : 'state . 'state mk_continue_fold_map = \{ fn = fun self visitor ->";
say ' {'; say ' {';
for $adts.list -> $t for $adts.list -> $t
{ say " $t<name> = \{"; { say " $t<name> = \{";
say " node__$t<name> = (fun x state -> _fold_map__$t<name> self visitor x state) ;"; say " node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> = (fun x state -> _fold_map__$t<name>__$c<name> self visitor x state) ;"; } { say " $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
say ' };' } say ' };' }
say ' }'; say ' }';
say '}'; say '}';
@ -391,47 +402,57 @@ say "";
# fold_map functions : tying the knot # fold_map functions : tying the knot
say ""; say "";
for $adts.list -> $t for $adts.list -> $t
{ say "let fold_map__$t<name> : type qstate . qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun visitor x state -> _fold_map__$t<name> mk_continue_fold_map visitor x state"; { say "let fold_map__$t<name> : type qstate . qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad =";
say " fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x";
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ say "let fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> { $c<type> || 'unit' } -> qstate -> ({ $c<newType> || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor x state"; } } { say "let fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad =";
say " fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x"; } }
say "let no_op : 'state . 'state fold_map_config = \{";
for $adts.list -> $t for $adts.list -> $t
{ say " $t<name> = \{"; {
say " node__$t<name> = (fun v state continue ->"; # (*_info*) say "let no_op_node__$t<name> : type state . state -> $t<name> -> state continue_fold_map -> (state * $t<newName>) monad =";
say " fun state v continue ->"; # (*_info*)
say " match v with"; say " match v with";
if ($t<kind> eq $variant) { if ($t<kind> eq $variant) {
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ given $c<type> { { given $c<type> {
when '' { say " | $c<name> -> let ((), state) = continue.$t<name>.$t<name>__$c<name> () state in ($c<newName>, state)"; } when '' { say " | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , $c<newName>)"; }
default { say " | $c<name> v -> let (v, state) = continue.$t<name>.$t<name>__$c<name> v state in ($c<newName> v, state)"; } } } default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } }
} elsif ($t<kind> eq $record) { } elsif ($t<kind> eq $record) {
print ' { '; print ' { ';
for $t<ctorsOrFields>.list -> $f for $t<ctorsOrFields>.list -> $f
{ print "$f<name>; "; } { print "$f<name>; "; }
say "} ->"; say "} ->";
for $t<ctorsOrFields>.list -> $f for $t<ctorsOrFields>.list -> $f
{ say " let ($f<newName>, state) = continue.$t<name>.$t<name>__$f<name> $f<name> state in"; } { say " continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
print ' ({ '; print ' return (state , ({ ';
for $t<ctorsOrFields>.list -> $f for $t<ctorsOrFields>.list -> $f
{ print "$f<newName>; "; } { print "$f<newName>; "; }
say '}, state)'; say "\} : $t<newName>))";
} else { } else {
print " v -> fold_map__$t<kind> v state ( "; print " v -> fold_map__$t<kind> ( ";
print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", "); print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
say " )"; say " ) state v";
} }
say " );"; }
say " node__$t<name>__pre_state = (fun v state -> ignore v; state) ;"; # (*_info*)
say " node__$t<name>__post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; # (*_info*) for $adts.list -> $t
{ say "let no_op__$t<name> : type state . state fold_map_config__$t<name> = \{";
say " node__$t<name> = no_op_node__$t<name>;";
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
for $t<ctorsOrFields>.list -> $c for $t<ctorsOrFields>.list -> $c
{ print " $t<name>__$c<name> = (fun v state continue -> "; # (*_info*) { print " $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
if ($c<isBuiltin>) { if ($c<isBuiltin>) {
print "ignore continue; (v, state)"; print "ignore continue; return (state , v)";
} else { } else {
print "continue.$c<type>.node__$c<type> v state"; print "continue.$c<type>.node__$c<type> state v";
} }
say ") ;"; } say ") ;"; }
say ' };' } say ' }' }
say "let no_op : type state . state fold_map_config = \{";
for $adts.list -> $t
{ say " $t<name> = no_op__$t<name>;" }
say '}'; say '}';

20
src/test/adt_generator/amodule_utils.ml
View File

@ -1,10 +1,14 @@
let fold_map__list v state continue = open Simple_utils.Trace
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__list continue state v =
let aux = fun acc elt ->
let%bind (state , lst') = acc in
let%bind (state , elt') = continue state elt in
ok (state , elt' :: lst') in
List.fold_left aux (ok (state, [])) v
let fold_map__option continue state v =
match v with match v with
Some x -> continue x state Some x -> continue state x
| None -> None | None -> ok None

5
src/test/adt_generator/dune
View File

@ -8,7 +8,10 @@
(executable (executable
(name test_adt_generator) (name test_adt_generator)
(public_name ligo.test_adt_generator) (public_name ligo.test_adt_generator)
(libraries adt_generator) (libraries adt_generator simple-utils)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
) )
(alias (alias

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

@ -1,44 +1,58 @@
open Amodule open Amodule
open Fold open Fold
open Simple_utils.Trace
module Errors = struct
let test_fail msg =
let title () = "test failed" in
let message () = msg in
error title message
end
(* TODO: how should we plug these into our test framework? *) (* TODO: how should we plug these into our test framework? *)
let test (x : unit result) : unit = match x with
| Ok (() , _annotation_thunk) -> ()
| Error err -> failwith (Yojson.Basic.to_string @@ err ())
let () = let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
let op = { let op = {
no_op with no_op with
a = { no_op.a with a = { no_op.a with
node__a = fun the_a (*_info*) state continue_fold -> node__a = fun state the_a (*_info*) continue_fold ->
let (a1__' , state') = continue_fold.ta1.node__ta1 the_a.a1 state in let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in
let (a2__' , state'') = continue_fold.ta2.node__ta2 the_a.a2 state' in let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in
({ a1__' ; a2__' }, state'' + 1) } ok (state + 1, { a1__' ; a2__' }) }
} in } in
let state = 0 in let state = 0 in
let (_, state) = fold_map__root op some_root state in let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else else
() ok ()
let () = let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in 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 = { no_op.a with node__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 state _the_a (*_info*) -> ok @@ state + 1 } } in
let state = 0 in let state = 0 in
let (_, state) = fold_map__root op some_root state in let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else else
() ok ()
let () = let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in 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 = { no_op.a with node__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 state _the_a _new_a (*_info*) -> ok @@ state + 1 } } in
let state = 0 in let state = 0 in
let (_, state) = fold_map__root op some_root state in let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else else
() ok ()
(* Test that the same fold_map_config can be ascibed with different 'a type arguments *) (* Test that the same fold_map_config can be ascibed with different 'a type arguments *)
@ -50,7 +64,7 @@ let () =
let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in
let nostate = false, "" in let nostate = false, "" in
let op = { let op = {
generic = (fun info state -> generic = (fun state info ->
assert_nostate state; assert_nostate state;
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | RecordInstance { fields } ->
@ -62,10 +76,10 @@ let () =
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate) (poly_continue nostate)
); );
string = (fun _visitor str state -> assert_nostate state; false , "\"" ^ str ^ "\"") ; string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor () state -> assert_nostate state; false , "()") ; unit = (fun _visitor state () -> assert_nostate state; false , "()") ;
int = (fun _visitor i state -> assert_nostate state; false , string_of_int i) ; int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
list = (fun _visitor lst continue state -> list = (fun _visitor continue state lst ->
assert_nostate state; assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ; false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
(* generic_ctor_or_field = (fun _info state -> (* generic_ctor_or_field = (fun _info state ->
@ -73,7 +87,7 @@ let () =
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]" * (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
* ); *) * ); *)
} in } in
let (_ , state) = fold__root op some_root nostate in let (_ , state) = 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 let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
if String.equal state expected; then if String.equal state expected; then
() ()