rose-ash/spec/signals.sx

(define-library
  (sx signals)
  (export
    make-signal
    signal?
    signal-value
    signal-set-value!
    signal-subscribers
    signal-add-sub!
    signal-remove-sub!
    signal-deps
    signal-set-deps!
    signal
    deref
    reset!
    swap!
    computed
    effect
    *batch-depth*
    *batch-queue*
    batch
    notify-subscribers
    flush-subscribers
    dispose-computed
    with-island-scope
    register-in-scope)
  (begin
    (define
      make-signal
      (fn
        (value)
        (dict
          "__signal"
          true
          "value"
          value
          "subscribers"
          (list)
          "deps"
          (list))))
    (define signal? (fn (x) (and (dict? x) (has-key? x "__signal"))))
    (define signal-value (fn (s) (get s "value")))
    (define signal-set-value! (fn (s v) (dict-set! s "value" v)))
    (define signal-subscribers (fn (s) (get s "subscribers")))
    (define
      signal-add-sub!
      (fn
        (s f)
        (when
          (not (contains? (get s "subscribers") f))
          (dict-set!
            s
            "subscribers"
            (append (get s "subscribers") (list f))))))
    (define
      signal-remove-sub!
      (fn
        (s f)
        (dict-set!
          s
          "subscribers"
          (filter
            (fn (sub) (not (identical? sub f)))
            (get s "subscribers")))))
    (define signal-deps (fn (s) (get s "deps")))
    (define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
    (define
      signal
      :effects ()
      (fn ((initial-value :as any)) (make-signal initial-value)))
    (define
      deref
      :effects ()
      (fn
        ((s :as any))
        (if
          (not (signal? s))
          s
          (let
            ((ctx (context "sx-reactive" nil)))
            (when
              ctx
              (let
                {:notify notify-fn :deps dep-list}
                ctx
                (when
                  (not (contains? dep-list s))
                  (append! dep-list s)
                  (signal-add-sub! s notify-fn))))
            (signal-value s)))))
    (define
      reset!
      :effects (mutation)
      (fn
        ((s :as signal) value)
        (when
          (signal? s)
          (let
            ((old (signal-value s)))
            (when
              (not (identical? old value))
              (signal-set-value! s value)
              (notify-subscribers s))))))
    (define
      swap!
      :effects (mutation)
      (fn
        ((s :as signal) (f :as callable) &rest args)
        (when
          (signal? s)
          (let
            ((old (signal-value s))
              (new-val (trampoline (apply f (cons old args)))))
            (when
              (not (identical? old new-val))
              (signal-set-value! s new-val)
              (notify-subscribers s))))))
    (define
      computed
      :effects (mutation)
      (fn
        ((compute-fn :as lambda))
        (let
          ((s (make-signal nil)) (deps (list)) (compute-ctx nil))
          (let
            ((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s))))))))
            (recompute)
            (register-in-scope (fn () (dispose-computed s)))
            s))))
    (define
      effect
      :effects (mutation)
      (fn
        ((effect-fn :as lambda))
        (let
          ((deps (list)) (disposed false) (cleanup-fn nil))
          (let
            ((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result))))))))
            (run-effect)
            (let
              ((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)))))
              (register-in-scope dispose-fn)
              dispose-fn)))))
    (define *batch-depth* 0)
    (define *batch-queue* (list))
    (define
      batch
      :effects (mutation)
      (fn
        ((thunk :as lambda))
        (set! *batch-depth* (+ *batch-depth* 1))
        (cek-call thunk nil)
        (set! *batch-depth* (- *batch-depth* 1))
        (when
          (= *batch-depth* 0)
          (let
            ((queue *batch-queue*))
            (set! *batch-queue* (list))
            (let
              ((seen (list)) (pending (list)))
              (for-each
                (fn
                  ((s :as signal))
                  (for-each
                    (fn
                      ((sub :as lambda))
                      (when
                        (not (contains? seen sub))
                        (append! seen sub)
                        (append! pending sub)))
                    (signal-subscribers s)))
                queue)
              (for-each (fn ((sub :as lambda)) (sub)) pending))))))
    (define
      notify-subscribers
      :effects (mutation)
      (fn
        ((s :as signal))
        (if
          (> *batch-depth* 0)
          (when (not (contains? *batch-queue* s)) (append! *batch-queue* s))
          (flush-subscribers s))))
    (define
      flush-subscribers
      :effects (mutation)
      (fn
        ((s :as dict))
        (for-each (fn (sub) (cek-call sub nil)) (signal-subscribers s))))
    (define
      dispose-computed
      :effects (mutation)
      (fn
        ((s :as signal))
        (when
          (signal? s)
          (for-each
            (fn ((dep :as signal)) (signal-remove-sub! dep nil))
            (signal-deps s))
          (signal-set-deps! s (list)))))
    (define
      with-island-scope
      :effects (mutation)
      (fn
        ((scope-fn :as lambda) (body-fn :as lambda))
        (scope-push! "sx-island-scope" scope-fn)
        (let ((result (body-fn))) (scope-pop! "sx-island-scope") result)))
    (define
      register-in-scope
      :effects (mutation)
      (fn
        ((disposable :as lambda))
        (let
          ((collector (scope-peek "sx-island-scope")))
          (when collector (cek-call collector (list disposable)))))))) ;; end define-library

;; Re-export to global namespace for backward compatibility
(import (sx signals))