Selkie.git | t/ | 19-store.rakutest

---

use Test;
use lib 'lib';

use Selkie::Store;
use Selkie::Widget;

# Concrete stub for testing
class TestWidget does Selkie::Widget {
    method render() { self.clear-dirty }
}

plan 33;

subtest "empty store" => {
    plan 2;
    my $s = Selkie::Store.new;
    is $s.db.elems, 0, "empty db";
    nok $s.get-in('x').defined, "get-in returns Nil for missing";
};

subtest "get-in / assoc-in" => {
    plan 3;
    my $s = Selkie::Store.new;
    $s.assoc-in('a', 'b', 'c', value => 42);
    is $s.get-in('a', 'b', 'c'), 42, "nested set/get";
    is $s.get-in('a', 'b').keys.sort.join(','), 'c', "intermediate hash exists";
    nok $s.get-in('a', 'x').defined, "missing path returns Nil";
};

subtest "assoc-in overwrites" => {
    plan 1;
    my $s = Selkie::Store.new;
    $s.assoc-in('x', value => 1);
    $s.assoc-in('x', value => 2);
    is $s.get-in('x'), 2, "overwrite works";
};

subtest "dispatch + handler + :db fx" => {
    plan 2;
    my $s = Selkie::Store.new;
    $s.register-handler('set-name', -> $store, %ev {
        (db => { user => { name => %ev<name> } },);
    });
    $s.dispatch('set-name', name => 'Matt');
    $s.tick;
    is $s.get-in('user', 'name'), 'Matt', "handler updated db";
    nok $s.get-in('user', 'age').defined, "unset paths still nil";
};

subtest "deep merge preserves existing keys" => {
    plan 2;
    my $s = Selkie::Store.new;
    $s.assoc-in('user', 'name', value => 'Matt');
    $s.assoc-in('user', 'age', value => 30);
    $s.register-handler('update', -> $store, %ev {
        (db => { user => { name => 'Updated' } },);
    });
    $s.dispatch('update');
    $s.tick;
    is $s.get-in('user', 'name'), 'Updated', "name updated";
    is $s.get-in('user', 'age'), 30, "age preserved";
};

subtest "db deep merge with empty hash preserves populated subtree" => {
    plan 2;
    my $s = Selkie::Store.new;
    $s.assoc-in('ui', 'image-gen', value => %(
        state    => 'sampling',
        progress => %(value => 4, max => 10),
    ));
    $s.register-handler('clear', -> $store, %ev {
        (db => { ui => { image-gen => %() } },);
    });
    $s.dispatch('clear');
    $s.tick;
    is $s.get-in('ui', 'image-gen')<state>, 'sampling',
        "empty Hash merge does not clear existing keys";
    is $s.get-in('ui', 'image-gen')<progress><value>, 4,
        "nested keys are preserved too";
};

subtest "db-replace replaces subtree with exact value" => {
    plan 3;
    my $s = Selkie::Store.new;
    $s.assoc-in('ui', 'image-gen', value => %(
        state    => 'sampling',
        progress => %(value => 4, max => 10),
    ));
    $s.assoc-in('ui', 'image-card-status', value => %(42 => %(state => 'generating')));
    $s.register-handler('replace', -> $store, %ev {
        (db-replace => { path => <ui image-gen>, value => %() },);
    });
    $s.dispatch('replace');
    $s.tick;
    my %slot = ($s.get-in('ui', 'image-gen') // %()).Hash;
    is %slot.elems, 0, "subtree replaced with empty Hash";
    nok %slot<state>:exists, "old scalar key removed";
    is $s.get-in('ui', 'image-card-status')<42><state>, 'generating',
        "sibling subtree preserved";
};

subtest "db-delete removes nested key and preserves siblings" => {
    plan 3;
    my $s = Selkie::Store.new;
    $s.assoc-in('ui', 'image-gen', value => %(state => 'sampling'));
    $s.assoc-in('ui', 'image-card-status', value => %(42 => %(state => 'generating')));
    $s.register-handler('delete', -> $store, %ev {
        (db-delete => { path => <ui image-gen> },);
    });
    $s.dispatch('delete');
    $s.tick;
    nok $s.get-in('ui', 'image-gen').defined, "target key deleted";
    ok $s.get-in('ui').keys.grep('image-card-status').elems,
        "sibling key still present";
    is $s.get-in('ui', 'image-card-status')<42><state>, 'generating',
        "sibling value preserved";
};

subtest "db-replace and db-delete notify path subscribers" => {
    plan 4;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.assoc-in('ui', 'image-gen', value => %(state => 'sampling'));
    $s.subscribe('image-gen-slot', ('ui', 'image-gen'), $w);
    $w.clear-dirty;

    $s.register-handler('replace', -> $store, %ev {
        (db-replace => { path => <ui image-gen>, value => %() },);
    });
    $s.dispatch('replace');
    $s.tick;
    ok $w.is-dirty, "replace marks subscribed widget dirty";
    is ($s.get-in('ui', 'image-gen') // %()).Hash.elems, 0,
        "replacement applied before subscription fires";

    $w.clear-dirty;
    $s.register-handler('delete', -> $store, %ev {
        (db-delete => { path => <ui image-gen> },);
    });
    $s.dispatch('delete');
    $s.tick;
    ok $w.is-dirty, "delete marks subscribed widget dirty";
    nok $s.get-in('ui', 'image-gen').defined,
        "delete applied before subscription fires";
};

subtest "event chaining via :dispatch fx" => {
    plan 1;
    my $s = Selkie::Store.new;
    $s.register-handler('first', -> $store, %ev {
        (dispatch => { event => 'second', val => 'from-first' },);
    });
    $s.register-handler('second', -> $store, %ev {
        (db => { result => %ev<val> },);
    });
    $s.dispatch('first');
    $s.tick;
    is $s.get-in('result'), 'from-first', "chained event processed";
};

subtest "multiple handlers on same event" => {
    plan 2;
    my $s = Selkie::Store.new;
    $s.register-handler('multi', -> $store, %ev {
        (db => { a => 1 },);
    });
    $s.register-handler('multi', -> $store, %ev {
        (db => { b => 2 },);
    });
    $s.dispatch('multi');
    $s.tick;
    is $s.get-in('a'), 1, "first handler ran";
    is $s.get-in('b'), 2, "second handler ran";
};

subtest "no handler for event is fine" => {
    plan 1;
    my $s = Selkie::Store.new;
    $s.dispatch('nonexistent');
    lives-ok { $s.tick }, "tick with no handler doesn't die";
};

subtest "path subscription marks dirty on change" => {
    plan 3;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.subscribe('name-sub', ('user', 'name'), $w);
    $w.clear-dirty;
    nok $w.is-dirty, "widget clean before tick";

    $s.register-handler('set', -> $store, %ev {
        (db => { user => { name => 'Changed' } },);
    });
    $s.dispatch('set');
    $s.tick;
    ok $w.is-dirty, "widget dirty after subscribed path changed";

    $w.clear-dirty;
    $s.tick;  # tick again with no changes
    nok $w.is-dirty, "widget NOT dirty when value unchanged";
};

subtest "path subscription ignores unrelated changes" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.subscribe('name-sub', ('user', 'name'), $w);
    # First tick primes the subscription (UNSET → current value)
    $s.tick;
    $w.clear-dirty;

    $s.register-handler('set-age', -> $store, %ev {
        (db => { user => { age => 30 } },);
    });
    $s.dispatch('set-age');
    $s.tick;
    nok $w.is-dirty, "widget NOT dirty when different path changed";
};

subtest "computed subscription" => {
    plan 2;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.assoc-in('first', value => 'Hello');
    $s.assoc-in('second', value => 'World');

    $s.subscribe-computed('full', -> $store {
        ($store.get-in('first') // '') ~ ' ' ~ ($store.get-in('second') // '');
    }, $w);
    $w.clear-dirty;

    $s.register-handler('change', -> $store, %ev {
        (db => { first => 'Hi' },);
    });
    $s.dispatch('change');
    $s.tick;
    ok $w.is-dirty, "computed sub fires when input changes";

    $w.clear-dirty;
    $s.tick;
    nok $w.is-dirty, "computed sub stable when no change";
};

subtest "unsubscribe" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.subscribe('temp', ('x',), $w);
    $s.unsubscribe('temp');
    $w.clear-dirty;

    $s.register-handler('set-x', -> $store, %ev {
        (db => { x => 1 },);
    });
    $s.dispatch('set-x');
    $s.tick;
    nok $w.is-dirty, "unsubscribed widget not notified";
};

subtest "unsubscribe-widget removes all subs for widget" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.subscribe('sub1', ('a',), $w);
    $s.subscribe('sub2', ('b',), $w);
    $s.unsubscribe-widget($w);
    $w.clear-dirty;

    $s.register-handler('set', -> $store, %ev {
        (db => { a => 1, b => 2 },);
    });
    $s.dispatch('set');
    $s.tick;
    nok $w.is-dirty, "all subs removed for widget";
};

subtest "handler receives current db state" => {
    plan 1;
    my $s = Selkie::Store.new;
    $s.assoc-in('count', value => 5);
    $s.register-handler('inc', -> $store, %ev {
        (db => { count => ($store.get-in('count') // 0) + 1 },);
    });
    $s.dispatch('inc');
    $s.tick;
    is $s.get-in('count'), 6, "handler saw existing state";
};

subtest "async fx dispatches on success" => {
    plan 1;
    my $s = Selkie::Store.new;
    $s.register-handler('start', -> $store, %ev {
        (async => {
            work       => -> { 42 },
            on-success => 'done',
        },);
    });
    $s.register-handler('done', -> $store, %ev {
        (db => { result => %ev<result> },);
    });
    $s.dispatch('start');
    $s.tick;
    # async runs on a thread — wait for it
    sleep 0.1;
    $s.tick;  # process the dispatched 'done' event
    is $s.get-in('result'), 42, "async result delivered";
};

subtest "async fx dispatches on failure" => {
    plan 4;
    my $s = Selkie::Store.new;
    $s.register-handler('start', -> $store, %ev {
        (async => {
            work       => -> { die "boom" },
            on-failure => 'failed',
        },);
    });
    my %failed;
    $s.register-handler('failed', -> $store, %ev {
        %failed = %ev;
        (db => { error => %ev<error> },);
    });
    $s.dispatch('start');
    $s.tick;
    $s.drain-async(:timeout(2));
    $s.tick;
    like $s.get-in('error'), /'boom'/, "failure event dispatched error message";
    like %failed<error>, /'boom'/, "failure payload includes error";
    ok %failed<exception>.defined, "failure payload includes exception object";
    ok %failed<backtrace>.defined && %failed<backtrace>.chars > 0,
        "failure payload includes backtrace";
};

subtest "get-in returns Array elements correctly" => {
    plan 4;
    my $s = Selkie::Store.new;
    my @items = <alpha beta gamma>;
    $s.assoc-in('list', value => @items);
    my $got = $s.get-in('list');
    ok $got ~~ Positional, "get-in returns something Positional";
    is $got.elems, 3, "correct number of elements";
    is $got[0], 'alpha', "first element accessible";

    # Critical: assigning get-in result to @ variable must decontainerize
    my @assigned = $s.get-in('list');
    is @assigned[0], 'alpha', "@ assignment extracts first element (not nested array)";
};

subtest "get-in returns objects correctly" => {
    plan 2;
    my $s = Selkie::Store.new;
    class TestObj { has Str $.name; }
    my @objs = TestObj.new(name => 'one'), TestObj.new(name => 'two');
    $s.assoc-in('items', value => @objs);
    $s.assoc-in('current', value => @objs[0]);

    my $current = $s.get-in('current');
    is $current.name, 'one', "get-in returns the object, not array";

    # Store Array then access element by index
    my @from-store = $s.get-in('items');
    is @from-store[0].name, 'one', "array element is the object, not nested";
};

subtest "handler gets decontainerized values via get-in" => {
    plan 2;
    my $s = Selkie::Store.new;
    my @items = <alpha beta gamma>;
    $s.assoc-in('app', 'items', value => @items);
    $s.assoc-in('app', 'current', value => @items[0]);

    my $saw-items-count;
    my $saw-current;
    $s.register-handler('check', -> $store, %ev {
        my @i = $store.get-in('app', 'items') // [];
        $saw-items-count = @i.elems;
        $saw-current = $store.get-in('app', 'current');
        ();
    });
    $s.dispatch('check');
    $s.tick;
    is $saw-items-count, 3, "handler sees array elements directly via get-in";
    is $saw-current, 'alpha', "handler sees scalar value via get-in";
};

subtest "handler array indexing works via get-in" => {
    plan 1;
    my $s = Selkie::Store.new;
    class TestItem { has Str $.label; }
    my @items = TestItem.new(label => 'first'), TestItem.new(label => 'second');
    $s.assoc-in('things', value => @items);

    my $got-label;
    $s.register-handler('pick', -> $store, %ev {
        my @things = $store.get-in('things') // [];
        $got-label = @things[0].label;
        ();
    });
    $s.dispatch('pick');
    $s.tick;
    is $got-label, 'first', "handler can index array and call methods on elements";
};

subtest "infinite dispatch loop protection" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $count = 0;
    $s.register-handler('loop', -> $store, %ev {
        $count++;
        (dispatch => { event => 'loop' },);
    });
    $s.dispatch('loop');
    $s.tick;
    ok $count <= 100, "loop capped at 100 iterations (ran $count)";
};

subtest "idle tick skips subscription compute" => {
    plan 3;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    my $compute-count = 0;
    $s.subscribe-computed('counter', -> $store {
        $compute-count++;
        $store.get-in('x') // 0;
    }, $w);

    $s.tick;  # primes — compute runs once
    is $compute-count, 1, "compute runs on priming tick";

    $s.tick;  # no events queued — compute should NOT run again
    is $compute-count, 1, "compute does NOT run on idle tick";

    $s.register-handler('set-x', -> $store, %ev {
        (db => { x => 42 },);
    });
    $s.dispatch('set-x');
    $s.tick;
    is $compute-count, 2, "compute runs again when an event was processed";
};

subtest "late-registered subscription primes on next tick" => {
    plan 2;
    my $s = Selkie::Store.new;
    $s.assoc-in('count', value => 7);
    $s.tick;  # initial prime with no subs

    my $w = TestWidget.new;
    my $seen;
    $s.subscribe-with-callback('late', -> $store {
        $store.get-in('count') // 0;
    }, -> $v { $seen = $v }, $w);
    $w.clear-dirty;

    # No dispatches, but the new subscription should still be primed.
    $s.tick;
    is $seen, 7, "callback fired with initial value on first tick after registration";
    ok $w.is-dirty, "widget marked dirty on priming tick";
};

subtest "multiple idle ticks do not re-fire primed subscription" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    my $fire-count = 0;
    $s.subscribe-with-callback('steady', -> $store {
        $store.get-in('x') // 0;
    }, -> $v { $fire-count++ }, $w);

    $s.tick;  # primes, callback fires once with 0
    $s.tick;  # idle
    $s.tick;  # idle
    $s.tick;  # idle
    is $fire-count, 1, "callback fires exactly once across idle ticks";
};

# --- Subscription mutation safety ----------------------------------------
#
# Regression coverage for the "Type check failed in binding to parameter
# '%sub'" crash that fired when a subscription callback called
# `unsubscribe` mid-tick. `Hash.kv` iterates lazily; without an `:exists`
# guard the next pair-bind hits Nil and fails the Associative check.
# Fixed in 0.5.3 — these subtests pin the new contract: callbacks may
# unsubscribe themselves or any sibling without crashing the iteration.

subtest "callback unsubscribing itself does not crash mid-tick" => {
    plan 2;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    my $fired = 0;
    $s.register-handler('bump', -> $st, %ev {
        (db => { n => ($st.get-in('n') // 0) + 1 },);
    });

    $s.subscribe-with-callback('self-killer',
        -> $store { $store.get-in('n') // 0 },
        -> $v {
            $fired++;
            $s.unsubscribe('self-killer');
        },
        $w);

    $s.dispatch('bump');
    lives-ok { $s.tick }, "tick survives self-unsubscribing callback";
    is $fired, 1, "callback fired exactly once before unsubscribing";
};

subtest "callback unsubscribing a sibling does not crash mid-tick" => {
    plan 2;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.register-handler('bump', -> $st, %ev {
        (db => { n => ($st.get-in('n') // 0) + 1 },);
    });

    my $sibling-fired = 0;
    $s.subscribe-with-callback('sibling',
        -> $store { $store.get-in('n') // 0 },
        -> $v { $sibling-fired++ },
        $w);

    my $killer-fired = 0;
    $s.subscribe-with-callback('killer',
        -> $store { $store.get-in('n') // 0 },
        -> $v {
            $killer-fired++;
            $s.unsubscribe('sibling');
        },
        $w);

    $s.dispatch('bump');
    lives-ok { $s.tick }, "tick survives sibling-unsubscribing callback";
    ok $killer-fired >= 1, "killer callback fired";
};

subtest "many sibling subs killed in one callback do not crash" => {
    plan 1;
    my $s = Selkie::Store.new;
    my $w = TestWidget.new;
    $s.register-handler('bump', -> $st, %ev {
        (db => { n => ($st.get-in('n') // 0) + 1 },);
    });

    # Register 20 dummy subs and one mass-killer that nukes them all
    # from a single callback firing — exercises the worst case where
    # most of the snapshot-keys list points at deleted entries by the
    # time we get to them.
    for ^20 -> $i {
        $s.subscribe-with-callback("dummy-$i",
            -> $store { $store.get-in('n') // 0 },
            -> $v { },
            $w);
    }
    $s.subscribe-with-callback('mass-killer',
        -> $store { $store.get-in('n') // 0 },
        -> $v { $s.unsubscribe("dummy-$_") for ^20 },
        $w);

    $s.dispatch('bump');
    lives-ok { $s.tick }, "tick survives mass-unsubscribe in one callback";
};

subtest "unsubscribe-widget cascade mid-tick does not corrupt iteration" => {
    # Forward-coverage of the contract: a callback may
    # `unsubscribe-widget` many siblings in one go (each widget
    # carrying its own cluster of subs) without breaking the outer
    # iteration. Multiple trials defeat hash-order luck.
    plan 1;

    my $message-count   = 40;   # roughly one chat-pane's worth
    my $subs-per-widget = 3;    # text-update, scroll, focus
    my $trial-count     = 8;    # defeat hash randomization

    my $all-survived = True;
    for ^$trial-count {
        my $s = Selkie::Store.new;
        my @msg-widgets = TestWidget.new xx $message-count;

        $s.register-handler('rebuild-list', -> $st, %ev {
            (db => { generation => ($st.get-in('generation') // 0) + 1 },);
        });

        for @msg-widgets.kv -> $i, $w {
            for ^$subs-per-widget -> $j {
                $s.subscribe-with-callback("msg-{$i}-sub-{$j}",
                    -> $store { $store.get-in('generation') // 0 },
                    -> $v { },
                    $w);
            }
        }

        my $orchestrator-widget = TestWidget.new;
        $s.subscribe-with-callback('orchestrator',
            -> $store { $store.get-in('generation') // 0 },
            -> $v {
                # The actual Cantina path: destroy all message widgets,
                # each cascading unsubscribe-widget.
                $s.unsubscribe-widget($_) for @msg-widgets;
            },
            $orchestrator-widget);

        $s.tick;                  # priming
        $s.dispatch('rebuild-list');

        my $survived = True;
        try {
            $s.tick;
            CATCH { default { $survived = False } }
        }
        $all-survived = False unless $survived;
    }

    ok $all-survived,
        "$trial-count trials of {$message-count}-widget mid-tick cascade all survived";
};

subtest "path-callback widget cascade from pull-sub callback survives" => {
    # Faithful reproduction of App::Cantina's character-change path:
    # 40 "message" widgets each carrying 3 path-callback subs (the
    # ChatMessage / ImageMessage shape), plus a pull-based
    # 'orchestrator' sub whose callback synchronously tears down
    # every message widget. The teardown cascades unsubscribe-widget
    # → 120 unsubscribes back into the very %!subscriptions hash
    # !check-subscriptions is walking. Pre-defer this crashed with
    # "Hash keys must be concrete strings (got )". Post-defer, the
    # 120 unsubscribes queue into $!pending-unsubscribes and the
    # LEAVE block flushes them after the walk completes.
    plan 3;

    my $s = Selkie::Store.new;
    my $orchestrator-widget = TestWidget.new;
    my @msg-widgets = TestWidget.new xx 40;

    # Seed the data each path-callback reads, so subscribe-path-callback's
    # synchronous priming has something to compute against.
    for ^40 -> $i {
        $s.assoc-in('msgs', "m{$i}", value => { content => '' });
    }

    my $msg-callback-fires = 0;
    for @msg-widgets.kv -> $i, $w {
        for ^3 -> $j {
            $s.subscribe-path-callback(
                "msg-{$i}-sub-{$j}",
                ('msgs', "m{$i}"),
                -> $msg { $msg-callback-fires++ },
                $w,
            );
        }
    }

    my $orchestrator-fired = 0;
    $s.subscribe-with-callback(
        'orchestrator',
        -> $store { $store.get-in('generation') // 0 },
        -> $v {
            $orchestrator-fired++;
            $s.unsubscribe-widget($_) for @msg-widgets;
        },
        $orchestrator-widget,
    );

    $s.register-handler('rebuild', -> $st, %ev {
        (db => { generation => ($st.get-in('generation') // 0) + 1 },);
    });

    $s.tick;                  # primes (orchestrator fires once with 0)
    $msg-callback-fires = 0;  # reset after priming fires

    $s.dispatch('rebuild');
    lives-ok { $s.tick }, "cascading path-callback teardown mid-tick survives";
    ok $orchestrator-fired >= 1, "orchestrator callback fired";

    # Behavioral cleanup check: after the deferred flush, writing to
    # any message's path must NOT invoke a per-widget callback, since
    # they should all have been unsubscribed.
    $msg-callback-fires = 0;
    $s.assoc-in('msgs', 'm0', value => { content => 'after' });
    $s.assoc-in('msgs', 'm17', value => { content => 'after' });
    $s.tick;
    is $msg-callback-fires, 0, "per-widget subs all cleaned up by walk exit";
};