From ded76b41d6d703b802ddc43f74f659f59603ad86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 1 Apr 2020 16:14:43 +0200 Subject: [PATCH] Adt generator: split structure into smaller structures; use the monad; reordered function, state and value arguments to match the order of List.fold_left. --- src/stages/4-ast_typed/PP_generic.ml | 42 ++++++++ src/stages/4-ast_typed/fold.ml | 1 + src/stages/4-ast_typed/types_utils.ml | 62 +++++++----- src/stages/adt_generator/generator.raku | 127 ++++++++++++++---------- src/test/adt_generator/amodule_utils.ml | 20 ++-- src/test/adt_generator/dune | 5 +- src/test/adt_generator/use_a_fold.ml | 56 +++++++---- 7 files changed, 205 insertions(+), 108 deletions(-) create mode 100644 src/stages/4-ast_typed/PP_generic.ml create mode 100644 src/stages/4-ast_typed/fold.ml diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml new file mode 100644 index 000000000..22ad1a2a1 --- /dev/null +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -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 diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml new file mode 100644 index 000000000..271974820 --- /dev/null +++ b/src/stages/4-ast_typed/fold.ml @@ -0,0 +1 @@ +include Generated_fold diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index e8f968b77..24835256c 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -1,4 +1,5 @@ module S = Ast_core +open Simple_utils.Trace (* include Stage_common.Types *) (* type expression_ @@ -28,32 +29,43 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe type location = Location.t 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 = - fun m state f -> - let aux k v (state , m) = let (new_v , state) = f v state in (state , CMap.add k new_v m) in - let (state , m) = CMap.fold aux m (state, CMap.empty) in - (m , 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 f state m -> + let aux k v acc = + let%bind (state , m) = acc in + 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 = - fun m state f -> - let aux k v (state , m) = let (new_v , state) = f v state in (state , LMap.add k new_v m) in - let (state , m) = LMap.fold aux m (state, LMap.empty) in - (m , 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 f state m -> + let aux k v acc = + let%bind (state , m) = acc in + 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 = - 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__list : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list -> (state * new_a list) Simple_utils.Trace.result = + fun f state l -> + 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 + 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 = - fun { wrap_content ; location } state f -> - let (state , wrap_content) = f wrap_content state in - ({ wrap_content ; location }, 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 f state { wrap_content ; location } -> + let%bind ( state , wrap_content ) = f state wrap_content in + 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 = - fun (first , l) state f -> - let (new_first , state) = f first state in - 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 - ((new_first , l), 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 f state (first , l) -> + let%bind (state , new_first) = f state first in + 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 + let%bind (state , l) = List.fold_left aux (ok (state , [])) l in + ok (state , (new_first , l)) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 57c27ee8c..adfd6b80d 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -143,9 +143,17 @@ say ""; for $statements -> $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 "module Adt_info = Adt_generator.Generic.Adt_info"; +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) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly"; } + say ""; for $adts.kv -> $index, $t { my $typeOrAnd = $index == 0 ?? "type" !! "and"; @@ -174,9 +182,9 @@ for $adts.kv -> $index, $t { say ""; for $adts.list -> $t { say "type 'state continue_fold_map__$t = \{"; - say " node__$t : $t -> 'state -> ($t * 'state) ;"; + say " node__$t : 'state -> $t -> ('state * $t) monad ;"; for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'}) monad ;" } say ' }'; } @@ -189,11 +197,11 @@ say ' }'; say ""; for $adts.list -> $t { say "type 'state fold_map_config__$t = \{"; - say " node__$t : $t -> 'state -> 'state continue_fold_map -> ($t * 'state) ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__pre_state : $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__post_state : $t -> $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t : 'state -> $t -> 'state continue_fold_map -> ('state * $t) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : 'state -> $t -> 'state monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : 'state -> $t -> $t -> 'state monad ;"; # (*Adt_info.node_instance_info ->*) for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> 'state -> 'state continue_fold_map -> ({$c || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) + { say " $t__$c : 'state -> {$c || 'unit'} -> 'state continue_fold_map -> ('state * {$c || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } say '}' } @@ -216,19 +224,21 @@ say "type 'state generic_continue_fold = ('state generic_continue_fold_node) Str say ""; say "type 'state fold_config ="; 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({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin -{ say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; } -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $builtin -{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; } +{ say " $builtin : 'state 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 fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } say ' }'; say ""; say 'type blahblah = {'; for $adts.list -> $t -{ say " fold__$t : 'state . blahblah -> 'state fold_config -> $t -> 'state -> 'state;"; +{ say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; for $t.list -> $c - { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> { $c || 'unit' } -> 'state -> 'state;"; } } + { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } say '}'; # generic programming info about the nodes and fields @@ -244,7 +254,7 @@ for $adts.list -> $t 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 x state;"; + say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor state x;"; say '}'; say ""; } say "(* info for node $t *)"; @@ -291,11 +301,11 @@ for $adts.list -> $t # 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 x ("; + 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);"; + say ") state x);"; say '};'; } }; @@ -312,25 +322,25 @@ say "]"; # fold functions say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate -> qstate = fun blahblah visitor x state ->"; +{ 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 (new_x, state) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic node_instance_info state"; + # 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 -> { $c || 'unit' } -> qstate -> qstate = fun blahblah { $c ?? 'visitor x' !! '_visitor ()' } state ->"; + { 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 " state"; + say " ignore blahblah; state"; } elsif ($c) { - say " ignore blahblah; visitor.$c visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + 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 x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + 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 ""; } @@ -344,11 +354,12 @@ for $adts.list -> $t { say " fold__$t__$c;" } } say '}'; +# Tying the knot say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state -> fold__$t blahblah visitor x state"; +{ 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 -> { $c || 'unit' } -> qstate -> qstate = fun visitor x state -> fold__$t__$c blahblah visitor x state" } } + { 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 ""; @@ -360,29 +371,29 @@ say '}'; # fold_map functions say ""; for $adts.list -> $t -{ say "let _fold_map__$t : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun mk_continue_fold_map visitor x state ->"; +{ say "let _fold_map__$t : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> $t -> (qstate * $t) 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 state = visitor.$t.node__$t__pre_state x state in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " let (new_x, state) = visitor.$t.node__$t x state continue_fold_map in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " let state = visitor.$t.node__$t__post_state x new_x state in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " (new_x, state)"; + 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 . qstate mk_continue_fold_map -> qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; + { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || '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 " visitor.$t.$t__$c x state continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + 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 : '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 ' {'; for $adts.list -> $t { say " $t = \{"; - say " node__$t = (fun x state -> _fold_map__$t self visitor x state) ;"; + say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; for $t.list -> $c - { say " $t__$c = (fun x state -> _fold_map__$t__$c self visitor x state) ;"; } + { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } say ' };' } say ' }'; say '}'; @@ -391,47 +402,57 @@ say ""; # fold_map functions : tying the knot say ""; for $adts.list -> $t -{ say "let fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state -> _fold_map__$t mk_continue_fold_map visitor x state"; +{ say "let fold_map__$t : type qstate . qstate fold_map_config -> qstate -> $t -> (qstate * $t) 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 . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t__$c mk_continue_fold_map visitor x state"; } } + { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }) monad ="; + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x"; } } -say "let no_op : 'state . 'state fold_map_config = \{"; for $adts.list -> $t -{ say " $t = \{"; - say " node__$t = (fun v state continue ->"; # (*_info*) +{ + say "let no_op_node__$t : type state . state -> $t -> state continue_fold_map -> (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 -> let ((), state) = continue.$t.$t__$c () state in ($c, state)"; } - default { say " | $c v -> let (v, state) = continue.$t.$t__$c v state in ($c v, state)"; } } } + 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 " let ($f, state) = continue.$t.$t__$f $f state in"; } - print ' ({ '; + { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } + print ' return (state , ({ '; for $t.list -> $f { print "$f; "; } - say '}, state)'; + say "\} : $t))"; } else { - print " v -> fold_map__$t v state ( "; + print " v -> fold_map__$t ( "; print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " )"; + say " ) state v"; } - say " );"; - say " node__$t__pre_state = (fun v state -> ignore v; state) ;"; # (*_info*) - say " node__$t__post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; # (*_info*) +} + +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 v state continue -> "; # (*_info*) + { print " $t__$c = (fun state v continue -> "; # (*_info*) if ($c) { - print "ignore continue; (v, state)"; + print "ignore continue; return (state , v)"; } else { - print "continue.$c.node__$c v state"; + print "continue.$c.node__$c state v"; } say ") ;"; } - say ' };' } + say ' }' } + +say "let no_op : type state . state fold_map_config = \{"; +for $adts.list -> $t +{ say " $t = no_op__$t;" } say '}'; diff --git a/src/test/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml index b0a666dd6..6befe8167 100644 --- a/src/test/adt_generator/amodule_utils.ml +++ b/src/test/adt_generator/amodule_utils.ml @@ -1,10 +1,14 @@ -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 +open Simple_utils.Trace -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 - Some x -> continue x state - | None -> None + Some x -> continue state x + | None -> ok None diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune index 679b3a0fd..63fabe8ed 100644 --- a/src/test/adt_generator/dune +++ b/src/test/adt_generator/dune @@ -8,7 +8,10 @@ (executable (name 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 diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 5591d87cf..617c5914c 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -1,44 +1,58 @@ open Amodule 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? *) +let test (x : unit result) : unit = match x with +| Ok (() , _annotation_thunk) -> () +| Error err -> failwith (Yojson.Basic.to_string @@ err ()) let () = + test @@ 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 = 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) } + node__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__' }) } } 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 - 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 - () + ok () let () = + test @@ 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) = fold_map__root op some_root state in + let%bind (state , _) = fold_map__root op state some_root in 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 - () + ok () let () = + test @@ 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) = fold_map__root op some_root state in + let%bind (state , _) = fold_map__root op state some_root in 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 - () + ok () (* 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 nostate = false, "" in let op = { - generic = (fun info state -> + generic = (fun state info -> assert_nostate state; match info.node_instance.instance_kind with | RecordInstance { fields } -> @@ -62,10 +76,10 @@ let () = | PolyInstance { poly=_; arguments=_; poly_continue } -> (poly_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 -> + 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_ctor_or_field = (fun _info state -> @@ -73,7 +87,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 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 ()