From 801efeed462e01f9328e1529314406aaabe3a0f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 6 Jan 2020 13:04:38 +0100 Subject: [PATCH] tests for automatic fold generator + fold_config hook to update the state before a node has been transformed, without transforming it. --- src/stages/adt_generator/fold.ml | 12 +++++++++++ src/stages/adt_generator/generator.py | 3 +++ src/stages/adt_generator/use_a_fold.ml | 30 ++++++++++++++++++++++++-- 3 files changed, 43 insertions(+), 2 deletions(-) diff --git a/src/stages/adt_generator/fold.ml b/src/stages/adt_generator/fold.ml index 3d04a1e13..4e4c41357 100644 --- a/src/stages/adt_generator/fold.ml +++ b/src/stages/adt_generator/fold.ml @@ -36,19 +36,23 @@ type 'state continue_fold = type 'state fold_config = { root : root -> 'state -> ('state continue_fold) -> (root' * 'state) ; + root_pre_state : root -> 'state -> 'state ; root_post_state : root -> root' -> 'state -> 'state ; root_A : a -> 'state -> ('state continue_fold) -> (a' * 'state) ; root_B : int -> 'state -> ('state continue_fold) -> (int * 'state) ; root_C : string -> 'state -> ('state continue_fold) -> (string * 'state) ; a : a -> 'state -> ('state continue_fold) -> (a' * 'state) ; + a_pre_state : a -> 'state -> 'state ; a_post_state : a -> a' -> 'state -> 'state ; a_a1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ; a_a2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ; ta1 : ta1 -> 'state -> ('state continue_fold) -> (ta1' * 'state) ; + ta1_pre_state : ta1 -> 'state -> 'state ; ta1_post_state : ta1 -> ta1' -> 'state -> 'state ; ta1_X : root -> 'state -> ('state continue_fold) -> (root' * 'state) ; ta1_Y : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ; ta2 : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ; + ta2_pre_state : ta2 -> 'state -> 'state ; ta2_post_state : ta2 -> ta2' -> 'state -> 'state ; ta2_Z : ta2 -> 'state -> ('state continue_fold) -> (ta2' * 'state) ; ta2_W : unit -> 'state -> ('state continue_fold) -> (unit * 'state) ; @@ -74,6 +78,7 @@ let rec mk_continue_fold : type state . state fold_config -> state continue_fold and fold_root : type state . state fold_config -> root -> state -> (root' * state) = fun visitor x state -> let continue_fold : state continue_fold = mk_continue_fold visitor in + let state = visitor.root_pre_state x state in let (new_x, state) = visitor.root x state continue_fold in let state = visitor.root_post_state x new_x state in (new_x, state) @@ -92,6 +97,7 @@ and fold_root_C : type state . state fold_config -> string -> state -> (string * and fold_a : type state . state fold_config -> a -> state -> (a' * state) = fun visitor x state -> let continue_fold : state continue_fold = mk_continue_fold visitor in + let state = visitor.a_pre_state x state in let (new_x, state) = visitor.a x state continue_fold in let state = visitor.a_post_state x new_x state in (new_x, state) @@ -106,6 +112,7 @@ and fold_a_a2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) and fold_ta1 : type state . state fold_config -> ta1 -> state -> (ta1' * state) = fun visitor x state -> let continue_fold : state continue_fold = mk_continue_fold visitor in + let state = visitor.ta1_pre_state x state in let (new_x, state) = visitor.ta1 x state continue_fold in let state = visitor.ta1_post_state x new_x state in (new_x, state) @@ -120,6 +127,7 @@ and fold_ta1_Y : type state . state fold_config -> ta2 -> state -> (ta2' * state and fold_ta2 : type state . state fold_config -> ta2 -> state -> (ta2' * state) = fun visitor x state -> let continue_fold : state continue_fold = mk_continue_fold visitor in + let state = visitor.ta2_pre_state x state in let (new_x, state) = visitor.ta2 x state continue_fold in let state = visitor.ta2_post_state x new_x state in (new_x, state) @@ -139,6 +147,7 @@ let no_op : 'a fold_config = { | B v -> let (v, state) = continue.root_B v state in (B' v, state) | C v -> let (v, state) = continue.root_C v state in (C' v, state) ); + root_pre_state = (fun v state -> ignore v; state) ; root_post_state = (fun v new_v state -> ignore (v, new_v); state) ; root_A = (fun v state continue -> continue.a v state ) ; root_B = (fun v state continue -> ignore continue; (v, state) ) ; @@ -150,6 +159,7 @@ let no_op : 'a fold_config = { let (a2', state) = continue.a_a2 a2 state in ({ a1'; a2'; }, state) ); + a_pre_state = (fun v state -> ignore v; state) ; a_post_state = (fun v new_v state -> ignore (v, new_v); state) ; a_a1 = (fun v state continue -> continue.ta1 v state ) ; a_a2 = (fun v state continue -> continue.ta2 v state ) ; @@ -158,6 +168,7 @@ let no_op : 'a fold_config = { | X v -> let (v, state) = continue.ta1_X v state in (X' v, state) | Y v -> let (v, state) = continue.ta1_Y v state in (Y' v, state) ); + ta1_pre_state = (fun v state -> ignore v; state) ; ta1_post_state = (fun v new_v state -> ignore (v, new_v); state) ; ta1_X = (fun v state continue -> continue.root v state ) ; ta1_Y = (fun v state continue -> continue.ta2 v state ) ; @@ -166,6 +177,7 @@ let no_op : 'a fold_config = { | Z v -> let (v, state) = continue.ta2_Z v state in (Z' v, state) | W v -> let (v, state) = continue.ta2_W v state in (W' v, state) ); + ta2_pre_state = (fun v state -> ignore v; state) ; ta2_post_state = (fun v new_v state -> ignore (v, new_v); state) ; ta2_Z = (fun v state continue -> continue.ta2 v state ) ; ta2_W = (fun v state continue -> ignore continue; (v, state) ) ; diff --git a/src/stages/adt_generator/generator.py b/src/stages/adt_generator/generator.py index e69a1fbf0..65fe21878 100644 --- a/src/stages/adt_generator/generator.py +++ b/src/stages/adt_generator/generator.py @@ -72,6 +72,7 @@ print(f"type 'state fold_config =") print(" {") for t in adts: print(f" {t.name} : {t.name} -> 'state -> ('state continue_fold) -> ({t.newName} * 'state) ;") + print(f" {t.name}_pre_state : {t.name} -> 'state -> 'state ;") print(f" {t.name}_post_state : {t.name} -> {t.newName} -> 'state -> 'state ;") for c in t.ctorsOrFields: print(f" {t.name}_{c.name} : {c.type_} -> 'state -> ('state continue_fold) -> ({c.newType} * 'state) ;") @@ -91,6 +92,7 @@ print("") for t in adts: print(f"and fold_{t.name} : type state . state fold_config -> {t.name} -> state -> ({t.newName} * state) = fun visitor x state ->") print(" let continue_fold : state continue_fold = mk_continue_fold visitor in") + print(f" let state = visitor.{t.name}_pre_state x state in") print(f" let (new_x, state) = visitor.{t.name} x state continue_fold in") print(f" let state = visitor.{t.name}_post_state x new_x state in") print(" (new_x, state)") @@ -120,6 +122,7 @@ for t in adts: print(f"{f.newName};", end=' ') print("}, state)") print(" );") + print(f" {t.name}_pre_state = (fun v state -> ignore v; state) ;") print(f" {t.name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;") for c in t.ctorsOrFields: print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ') diff --git a/src/stages/adt_generator/use_a_fold.ml b/src/stages/adt_generator/use_a_fold.ml index 13f78e040..6a73f4782 100644 --- a/src/stages/adt_generator/use_a_fold.ml +++ b/src/stages/adt_generator/use_a_fold.ml @@ -1,7 +1,9 @@ open A open Fold -let _ = +(* TODO: how should we plug these into our test framework? *) + +let () = let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in let op = { no_op with @@ -15,8 +17,32 @@ let _ = } in let state = 0 in let (_, state) = fold_root op some_root state in - Printf.printf "trilili %d" state + if state != 2 then + failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) + else + () + +let () = + let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in + let op = { no_op with a_pre_state = fun _the_a state -> state + 1 } in + let state = 0 in + let (_, state) = fold_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 + () + +let () = + let some_root : root = A { a1 = X (A { a1 = X (B 1) ; a2 = W () ; }) ; a2 = Z (W ()) ; } in + let op = { no_op with a_post_state = fun _the_a _new_a state -> state + 1 } in + let state = 0 in + let (_, state) = fold_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 _ -> ()) *)