Selkie.git | t/ | 100-store-schema.rakutest
use Test;
use lib 'lib';
use Selkie::Store::Schema;
# Pure unit tests for the Schema value classes — no Store, no
# notcurses. The contract under test is the immutability discipline
# everything else leans on: writes return new instances sharing
# unchanged branches, no-op writes return the SAME instance, unknown
# slots die loudly, and changed-paths finds exactly what changed by
# identity diff.
plan 9;
class T::Ui is Selkie::Store::Schema::UI {
has Bool $.sidebar-open = True;
}
class T::Job is Selkie::Store::Schema {
has Str $.title = '';
has Int $.progress = 0;
}
class T::Db is Selkie::Store::Schema {
has T::Ui $.ui .= new;
has T::Job $.job .= new;
has Str $.user-name = '';
has Int $.count = 0;
has $.cursor; # untyped, starts undefined
has @.tasks;
has %.prefs;
}
subtest "slot introspection" => {
plan 6;
my $db = T::Db.new;
is-deeply $db.slot-names,
<count cursor job prefs tasks ui user-name>.List,
"slot-names lists every public attribute, sorted";
ok $db.has-slot('user-name'), "has-slot true for a declared slot";
nok $db.has-slot('nope'), "has-slot false for an unknown name";
is $db.slot-value('count'), 0, "slot-value reads a slot";
ok $db.slot-value('ui') ~~ T::Ui, "slot-value reads a nested schema";
throws-like { $db.slot-value('nope') }, Exception,
message => /"No such slot 'nope'"/,
"slot-value dies on unknown slot";
};
subtest "with — replacement, validation, typing" => {
plan 6;
my $db = T::Db.new;
my $next = $db.with(user-name => 'Kai', count => 3);
is $next.user-name, 'Kai', "with replaces the named slots";
is $next.count, 3, "…all of them";
is $db.user-name, '', "…and the original instance is untouched";
ok $next.ui === $db.ui,
"untouched branches are shared by reference (structural sharing)";
throws-like { $db.with(user-nmae => 'Kai') }, Exception,
message => /"No such slot 'user-nmae' on T::Db"/,
"unknown slot dies naming the class";
throws-like { $db.with(count => 'not-an-int') },
X::TypeCheck::Assignment,
"type constraints are enforced by the clone";
};
subtest "with — no-op writes keep identity" => {
plan 5;
my $db = T::Db.new(user-name => 'Kai');
ok $db.with() === $db, "empty override set returns self";
ok $db.with(user-name => 'Kai') === $db,
"=== -equal value returns self (value types compare by content)";
ok $db.with(cursor => Nil) === $db,
"undefined-to-undefined returns self";
my @tasks = <a b>;
my $with-tasks = $db.with(tasks => @tasks);
ok $with-tasks.with(tasks => [|$with-tasks.tasks]) === $with-tasks,
"collection slots: equal-element array is a no-op (one-level element identity)";
nok $with-tasks.with(tasks => ['a', 'CHANGED']) === $with-tasks,
"collection slots: a changed element is a real write";
};
subtest "with-* FALLBACK sugar" => {
plan 4;
my $db = T::Db.new;
is $db.with-user-name('Kai').user-name, 'Kai',
"with-<slot> delegates to with";
throws-like { $db.with-user-nmae('Kai') }, Exception,
message => /"no slot 'user-nmae'"/,
"with-* with unknown slot dies and names it";
throws-like { $db.with-user-name('a', 'b') }, Exception,
message => /"exactly one positional"/,
"with-* arity is enforced";
throws-like { $db.frobnicate }, Exception,
message => /"No such method 'frobnicate'"/,
"non-with-* unknown methods still die method-not-found";
};
subtest "merge — deep-merge parity with the db effect" => {
plan 8;
my $db = T::Db.new(prefs => { theme => 'dark', fonts => { size => 12 } });
my $next = $db.merge({ ui => { sidebar-open => False }, count => 2 });
is $next.ui.sidebar-open, False, "Hash value merging into a Schema slot recurses";
is $next.count, 2, "scalar values replace";
ok $next.job === $db.job, "untouched schema branches keep identity";
my $prefs = $db.merge({ prefs => { theme => 'light' } });
is $prefs.prefs<theme>, 'light', "plain-Hash slot deep-merges";
is $prefs.prefs<fonts><size>, 12, "…preserving unmentioned nested keys";
ok $prefs.prefs<fonts> === $db.prefs<fonts>,
"…and sharing untouched hash branches";
ok $db.merge({}) === $db, "empty merge is a no-op returning self";
throws-like { $db.merge({ nope => 1 }) }, Exception,
message => /"No such slot 'nope'"/,
"unknown key dies";
};
subtest "set-at — path writes" => {
plan 7;
my $db = T::Db.new;
is $db.set-at(('user-name',), 'Kai').user-name, 'Kai',
"single-segment path sets the slot";
is $db.set-at(('ui', 'sidebar-open'), False).ui.sidebar-open, False,
"descent through a Schema slot";
my $deep = $db.set-at(('prefs', 'fonts', 'size'), 14);
is $deep.prefs<fonts><size>, 14,
"descent into a plain-Hash region auto-vivifies intermediates";
ok $db.prefs<fonts>:!exists,
"…without mutating the original";
ok $db.set-at(('ui', 'sidebar-open'), True) === $db,
"no-op set keeps identity all the way up";
throws-like { $db.set-at(('nope', 'x'), 1) }, Exception,
message => /"No such slot 'nope'"/,
"unknown first segment dies (no auto-creation on schema nodes)";
throws-like { $db.set-at((), 1) }, Exception,
message => /"Path must not be empty"/,
"empty path dies";
};
subtest "deleted-at — reset semantics" => {
plan 8;
my $db = T::Db.new(
user-name => 'Kai', count => 5, cursor => 9,
tasks => <a b>, prefs => { theme => 'dark', fonts => { size => 12 } },
);
nok $db.deleted-at(('cursor',)).cursor.defined,
"\$-slot resets to undefined";
is $db.deleted-at(('count',)).count, Int,
"typed \$-slot resets to the container default (type object)";
is-deeply $db.deleted-at(('tasks',)).tasks, [],
"\@-slot resets to empty";
my $fresh = T::Db.new;
ok $fresh.deleted-at(('tasks',)) === $fresh,
"already-empty \@-slot delete is a no-op";
my $del = $db.deleted-at(('prefs', 'theme'));
ok $del.prefs<theme>:!exists, "plain-Hash region: classic key delete";
is $del.prefs<fonts><size>, 12, "…other keys survive";
ok $db.deleted-at(('prefs', 'no-such-key')) === $db,
"missing key in a hash region is a no-op returning self";
throws-like { $db.deleted-at(('nope',)) }, Exception,
message => /"No such slot 'nope'"/,
"unknown slot dies";
};
subtest "changed-paths — identity diff" => {
plan 7;
my $db = T::Db.new;
is-deeply $db.with(user-name => 'Kai').changed-paths($db),
(('user-name',),).List,
"a leaf change reports exactly its path";
is-deeply $db.merge({ ui => { sidebar-open => False } }).changed-paths($db),
(('ui', 'sidebar-open'),).List,
"a nested schema change reports the precise nested path";
is-deeply $db.with(count => 1, user-name => 'x').changed-paths($db),
(('count',), ('user-name',)).List,
"multiple changes report sorted by slot name";
is-deeply $db.set-at(('prefs', 'theme'), 'dark').changed-paths($db),
(('prefs',),).List,
"a plain-Hash slot marks the whole slot (blunt but correct)";
is-deeply $db.changed-paths($db), ().List,
"diff against self is empty";
my $noop = $db.with(user-name => '');
is-deeply $noop.changed-paths($db), ().List,
"a no-op write diffs empty (identity preserved)";
my $swapped = $db.with(job => T::Job.new(title => 'x'));
is-deeply $swapped.changed-paths($db),
(('job', 'title'),).List,
"a replaced same-class schema instance still diffs per-slot";
};
subtest "Schema::UI carries the framework slots" => {
plan 3;
my $ui = Selkie::Store::Schema::UI.new;
ok $ui.has-slot('focused-widget') && $ui.has-slot('focus-action'),
"focused-widget + focus-action slots exist";
is T::Ui.new.slot-names, <focus-action focused-widget sidebar-open>.List,
"subclasses inherit them alongside their own slots";
is $ui.with(focus-action => 'next').focus-action, 'next',
"framework slots write like any other";
};