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
            ((dep-list (get ctx "deps")) (notify-fn (get ctx "notify")))
            (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))