Биндинги.

{$ifdef description}
   БИНДИНГ (Binding) — управляемая обёртка над BindingInstance —
   это штука, которую можно добавить в МЕНЕДЖЕР БИНДИНГОВ (BindingManager).

   BindingManager.ForEach обходит все биндинги в порядке добавления,
   а деструктор биндинга автоматически удаляет его из менеджера, в который он добавлен.

   Это удобно для вещей, которые можно куда-то добавлять и (обычно автоматически) удалять.
   Например, для цепочки обработчиков нажатия клавиши Z:
       private
           onPressZ: BindingManager;
       public
           type PressZCallback = function(...);
           function BindPressZ(func: PressZCallback): PressZBinding;
           procedure CallPressZ;

   BindPressZ регистрирует биндинг и возвращает пользователю управляемую ссылку на него:
       binding := PressZBindingInstance.Create(func);
       onPressZ.Add(binding);
       result := binding;

   CallPressZ вызывает все зарегистрированные обработчики:
       onPressZ.ForEach(b -> (b as PressZBindingInstance).func());

   Когда пользователь прекратит удерживать binding, он автоматически удалится из onPressZ.
   В частности, если функция регистрируется в пределах жизни некоторого объекта — такого как окно, реагирующее на клавишу Z,
   биндинг естественно сохранить как поле этого объекта, чтобы регистрация автоматически отзывалась с закрытием окна.

   Полностью поддерживаются добавления и удаления в ходе ForEach.
   В нашем случае это означает, что обработчик Z свободен в установке и удалении других обработчиков Z, в частности, может разрегистрировать сам себя.

   Семантика вложенных операций:
   — Удаления биндингов видны для ForEach, в котором произошли, т. е. он не будет проходить элементы, удалённые в процессе собственной работы.
     Если хранятся 'ABCDE' и в момент прохода по 'B' удаляется 'D', то по окончании ForEach окажутся пройденными 'ABСE'.

   — Добавления, наоборот, не видны ForEach-у, в котором произошли.
     Если хранятся 'ABCDE' и ForEach добавляет по 1 элементу: на 'A' — 'a', ..., 'E' — 'e', то будут пройдены 'ABCDE', а полный список станет 'ABCDEabcde'.

   — Но добавления видны вложенным ForEach, причём по состоянию на момент их начала.
     Если хранятся 'ABCDE', ForEach добавляет на 'A' — 'a', ..., 'E' — 'e', и на 'C' вызывается вложенный ForEach2,
     то ForEach2 пройдёт 'ABCDEabc', а внешний ForEach так и завершится на 'ABCDE'.

   В будущем может понадобиться явное управление порядком посредством приоритетов,
   но тогда вместо простого связного списка придётся использовать красно-чёрное дерево. :)
{$endif}

{$include opts.inc}
unit Framework.System.Bindings;

{$include non_copyable.inc} {$include enum_shortcuts.inc} {$include logging.inc}

interface

uses
    Framework.System.Common, Framework.System.Threads;

type
    pBindingManager = ^BindingManager;
    BindingInstance = class;

    Binding = record
    {$define typ := Binding} {$define instance := BindingInstance} {$include shared_ref.h.inc}
    end;

    BindingInstance = class(Refcounted)
        destructor Destroy; override;
    protected
        procedure Teardown; virtual;
    private type
        pNode = ^Node;
        Node = record
            man: pBindingManager;
            b: BindingInstance;
            prev, next, nextRemoved: pNode;
        end;
    const
        TEARING_DOWN = pNode(1);
    var
        n: pNode;
    end;

    BindingManager = record
        {$define enum := SelfSufficientLockDescEnum} {$define items := NoLock _ OwnLock} enum_shortcuts
        {$define enum := TraversalDirection} {$define items := Straight _ Reversed} enum_shortcuts
    type
        LockDesc = record
        {$define enum := ModeEnum} {$define items := DontUse _ External _ Own _ Dead} enum_shortcuts
            class operator :=(mode: SelfSufficientLockDescEnum): LockDesc;
            class operator :=(const lock: ThreadLockReference): LockDesc;
        private
            mode: ModeEnum;
            lock: ThreadLockReference;
        end;

        BindingProc = procedure(b: BindingInstance; param: pointer);
        BreakableBindingProc = function(b: BindingInstance; param: pointer): boolean;

        procedure Init(const lock: LockDesc; const name: string);
        function OK: boolean;
        procedure Add(const b: Binding);
        procedure Add(b: BindingInstance);
        procedure ForEach(proc: BindingProc; param: pointer; direction: TraversalDirection = Straight);
        procedure ForEach(proc: BreakableBindingProc; param: pointer; direction: TraversalDirection = Straight);
    private type
        pNode = BindingInstance.pNode;
        // Node = BindingInstance.Node;

        AdaptBindingProcAsBreakableContext = record
            proc, param: pointer;
        end;
    const
        // используется вместо nil как маркер конца списка removedHead, чтобы можно было проверить, удалён ли узел, через Assigned(nextRemoved).
        LAST_REMOVED = pNode(1);
    var
        first, last, removedHead: pNode;
        _lock: LockDesc;
        busy: uint;
        name: string;
        function CreateNode: pNode;
        procedure DestroyNode(n: pNode);
        procedure Remove(n: pNode);
        procedure RemoveRightAway(n: pNode);
        procedure PostponeRemove(n: pNode);
        procedure SweepPostponedRemoves;
        procedure Lock;
        procedure Unlock;
        function Mine: boolean;
        procedure LockOwn(const what: string);
        procedure UnlockOwn;
        class function AdaptBindingProcAsBreakable(b: BindingInstance; param: pointer): boolean; static;
    {$define typ := BindingManager} {$define initfinal} non_copyable
    end;

implementation

uses
    Framework.System;

    {$define typ := Binding} {$include shared_ref.pp.inc}

    destructor BindingInstance.Destroy;
    var
        savedN: pNode;
    begin
        if Assigned(n) then
        begin
            Assert(n <> TEARING_DOWN, 'Binding.Destroy повторилась рекурсивно');
            savedN := n;
            n := TEARING_DOWN;
            savedN^.man^.Remove(savedN);
            Teardown;
        end;
        inherited Destroy;
    end;

    procedure BindingInstance.Teardown;
    begin
    end;

    class operator BindingManager.LockDesc.:=(mode: SelfSufficientLockDescEnum): LockDesc;
    begin
        case mode of
            NoLock: result.mode := DontUse;
            OwnLock: result.mode := Own;
        end;
    end;

    class operator BindingManager.LockDesc.:=(const lock: ThreadLockReference): LockDesc;
    begin
        result.mode := External;
        result.lock := lock;
    end;

    procedure BindingManager.Init(const lock: LockDesc; const name: string);
    begin
        if OK then ThrowOpenedOver('BindingManager', name, self.name);
        _lock := lock;
        if _lock.mode = lock.Own then _lock.lock := RecursiveThreadLock.Create^;
        self.name := name;
    end;

    function BindingManager.OK: boolean;
    begin
        result := self._lock.mode <> LockDesc.Dead;
    end;

    procedure BindingManager.Add(const b: Binding);
    begin
        Add(b.p);
    end;

    procedure BindingManager.Add(b: BindingInstance);
    var
        n: pNode;
    begin
        Assert(OK);
        if Assigned(b.n) then raise Error('{} уже привязана.', b.ToString);
        LockOwn('Add');
        try
            // Add работает безотносительно busy.
            n := CreateNode;
            n^.b := b;
            n^.prev := last;
            n^.next := nil;
            n^.nextRemoved := nil;
            if Assigned(last) then last^.next := n else first := n;
            last := n;
            b.n := n;
        finally
            UnlockOwn;
        end;
    end;

    procedure BindingManager.ForEach(proc: BindingProc; param: pointer; direction: TraversalDirection = Straight);
    var
        ctx: AdaptBindingProcAsBreakableContext;
    begin
        ctx.proc := proc;
        ctx.param := param;
        ForEach(@AdaptBindingProcAsBreakable, @ctx, direction);
    end;

    procedure BindingManager.ForEach(proc: BreakableBindingProc; param: pointer; direction: TraversalDirection = Straight);
    var
        cur, lastVisible: pNode;
    begin
        Assert(OK);
        LockOwn('ForEach');
        inc(busy);
        try
            if direction = Straight then
            begin
                cur := first;
                if not Assigned(cur) then exit;
                lastVisible := last;

                // Хитрое условие, чтобы записать всё в одну строчку.
                // Если Assigned(cur^.nextRemoved) — элемент отложенно удалён, и proc вызывать не нужно.
                // Иначе вызывается proc. Если она вернула ложь, т. е. явно попросила прерваться — цикл прерывается.
                // Наконец, если cur = lastVisible, то это был последний (по состоянию на начало ForEach) элемент в списке.
                // При busy удаления исполняются отложенно, и это гарантирует, что lastVisible никуда из списка не денется.
                while (Assigned(cur^.nextRemoved) or proc(cur^.b, param)) and (cur <> lastVisible) do
                    cur := cur^.next;
            end else
            begin
                // Код обхода в обратном направлении полностью зеркалит код обхода в прямом на случай,
                // если будет добавлена поддержка добавления элементов в начало.
                cur := last;
                if not Assigned(cur) then exit;
                lastVisible := first;
                while (Assigned(cur^.nextRemoved) or proc(cur^.b, param)) and (cur <> lastVisible) do
                    cur := cur^.prev;
            end;
        finally
            dec(busy);
            if busy = 0 then SweepPostponedRemoves;
            UnlockOwn;
        end;
    end;

    function BindingManager.CreateNode: pNode;
    begin
        new(result);
        result^.man := @self;
    end;

    procedure BindingManager.DestroyNode(n: pNode);
    begin
        dispose(n);
    end;

    procedure BindingManager.Remove(n: pNode);
    begin
        Lock;
        try
            if busy = 0 then RemoveRightAway(n) else PostponeRemove(n);
        finally
            Unlock;
        end;
    end;

    procedure BindingManager.RemoveRightAway(n: pNode);
    var
        prev, next: pNode;
    begin
        Assert(Mine);
        Assert(n^.man = @self);
        prev := n^.prev;
        next := n^.next;

        if Assigned(prev) then prev^.next := next else begin Assert(n = first); first := next; end;
        if Assigned(next) then next^.prev := prev else begin Assert(n = last); last := prev; end;
        DestroyNode(n);
    end;

    procedure BindingManager.PostponeRemove(n: pNode);
    begin
        Assert(Mine);
        Assert(n^.man = @self);
        Assert(not Assigned(n^.nextRemoved));
        if Assigned(removedHead) then n^.nextRemoved := removedHead else n^.nextRemoved := LAST_REMOVED;
        removedHead := n;
    end;

    procedure BindingManager.SweepPostponedRemoves;
    var
        cur, nx: pNode;
    begin
        if Assigned(removedHead) then
        begin
            cur := removedHead;
            repeat
                nx := cur^.nextRemoved;
                RemoveRightAway(cur);
                cur := nx;
            until cur = LAST_REMOVED;
            removedHead := nil;
        end;
    end;

    procedure BindingManager.Lock;
    begin
        if _lock.mode <> _lock.DontUse then _lock.lock.Enter;
    end;

    procedure BindingManager.Unlock;
    begin
        if _lock.mode <> _lock.DontUse then _lock.lock.Leave;
    end;

    function BindingManager.Mine: boolean;
    begin
        case _lock.mode of
            _lock.Own, _lock.External: result := _lock.lock.Mine;
            else result := yes;
        end;
    end;

    procedure BindingManager.LockOwn(const what: string);
    begin
        case _lock.mode of
            _lock.Own: Lock;
            _lock.External: Assert(_lock.lock.Mine, '{} должна выполняться под блокировкой'.Format(what));
            else ;
        end;
    end;

    procedure BindingManager.UnlockOwn;
    begin
        case _lock.mode of
            _lock.Own: Unlock;
            else ;
        end;
    end;

    class function BindingManager.AdaptBindingProcAsBreakable(b: BindingInstance; param: pointer): boolean;
    var
        ctx: ^AdaptBindingProcAsBreakableContext absolute param;
    begin
        BindingProc(ctx^.proc)(b, ctx^.param);
        result := yes;
    end;

    class operator BindingManager.Initialize(var self: BindingManager);
    begin
        self.first := nil;
        self.last := nil;
        self.removedHead := nil;
        self._lock.mode := LockDesc.Dead;
        self.busy := 0;
    end;

    class operator BindingManager.Finalize(var self: BindingManager);

        procedure EmergencyFreeDanglingNodes;
        var
            count: SizeUint;
            cur, next: pNode;
        begin
            count := 0;
            cur := self.first;
            while Assigned(cur) do
            begin
                inc(count);
                next := cur^.next;
                cur^.b.n := nil;
                self.DestroyNode(cur);
                cur := next;
            end;
            log_warning('В BindingManager({}) остал{1:ся/ись/ось} {} незакрытых биндинг{/а/ов}.'.Format(self.name, count.ToString));
        end;

    begin
        // По-хорошему этого не должно быть, но может происходить в искусственных примерах.
        if Assigned(self.first) then EmergencyFreeDanglingNodes;
        if (self._lock.Mode = LockDesc.Own) and Assigned(self._lock.lock.Plain) then dispose(self._lock.lock.Plain);
        self._lock.Mode := LockDesc.Dead;
    end;

{$define typ := BindingManager} non_copyable_impl

end.