rose-ash/lib/content/doc.sx

;; content-on-sx — ordered block document on Smalltalk-on-SX.
;;
;; A document (CtDoc) is a Smalltalk object holding an ordered sequence of block
;; objects. Editing is a stream of ops (data dicts); doc-apply interprets one op
;; and returns a NEW document — the input is never mutated, so any version is the
;; head of an op stream (replay-friendly for persist + CRDT merge).
;;
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
;; ergonomic API; they default nil and do not affect block operations.
;;
;; Op shapes (data, not objects — they are the persist event payload):
;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend
;;   {:op "update" :id <id> :field <name> :value <v>}
;;   {:op "move"   :id <id> :index <n>}
;;   {:op "delete" :id <id>}

(define
  content-bootstrap-doc!
  (fn
    ()
    (begin
      (st-class-define!
        "CtDoc"
        "Object"
        (list "id" "blocks" "title" "slug" "tags"))
      (ct-def-method! "CtDoc" "id" "id ^ id")
      (ct-def-method! "CtDoc" "blocks" "blocks ^ blocks")
      (ct-def-method! "CtDoc" "type" "type ^ #document")
      (ct-def-method! "CtDoc" "title" "title ^ title")
      (ct-def-method! "CtDoc" "slug" "slug ^ slug")
      (ct-def-method! "CtDoc" "tags" "tags ^ tags")
      true)))

;; ── construction ──
(define
  doc-new
  (fn
    (id blocks)
    (st-iv-set!
      (st-iv-set! (st-make-instance "CtDoc") "id" id)
      "blocks"
      blocks)))

(define doc-empty (fn (id) (doc-new id (list))))

;; ── accessors (message dispatch) ──
(define doc-id (fn (doc) (st-send doc "id" (list))))
(define doc-type (fn (doc) (str (st-send doc "type" (list)))))
(define doc-blocks (fn (doc) (st-send doc "blocks" (list))))
(define doc-count (fn (doc) (len (doc-blocks doc))))
(define doc-block-at (fn (doc i) (nth (doc-blocks doc) i)))

(define doc? (fn (v) (and (st-instance? v) (= (get v :class) "CtDoc"))))

;; ── list helpers over block sequences ──
(define
  ct-index-loop
  (fn
    (blocks id i)
    (cond
      ((= (len blocks) 0) -1)
      ((= (blk-id (first blocks)) id) i)
      (else (ct-index-loop (rest blocks) id (+ i 1))))))

(define ct-index-of (fn (blocks id) (ct-index-loop blocks id 0)))

(define
  ct-insert-at
  (fn
    (blocks i x)
    (cond
      ((= i 0) (cons x blocks))
      ((= (len blocks) 0) (list x))
      (else
        (cons
          (first blocks)
          (ct-insert-at (rest blocks) (- i 1) x))))))

(define
  ct-remove-id
  (fn
    (blocks id)
    (filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))

(define
  ct-replace-id
  (fn
    (blocks id f)
    (map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))

;; ── query ──
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))

(define
  doc-find
  (fn
    (doc id)
    (let
      ((hits (filter (fn (b) (= (blk-id b) id)) (doc-blocks doc))))
      (if (= (len hits) 0) nil (first hits)))))

(define
  doc-has?
  (fn (doc id) (if (= (doc-index-of doc id) -1) false true)))

;; ── structural edits (each returns a new document) ──
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))

(define
  doc-append
  (fn
    (doc block)
    (doc-with-blocks doc (append (doc-blocks doc) (list block)))))

(define
  doc-insert-at
  (fn
    (doc block i)
    (doc-with-blocks doc (ct-insert-at (doc-blocks doc) i block))))

(define
  doc-insert-after
  (fn
    (doc block after-id)
    (let
      ((blocks (doc-blocks doc)))
      (if
        (= after-id nil)
        (doc-with-blocks doc (cons block blocks))
        (let
          ((idx (ct-index-of blocks after-id)))
          (if
            (= idx -1)
            (doc-with-blocks doc (append blocks (list block)))
            (doc-with-blocks
              doc
              (ct-insert-at blocks (+ idx 1) block))))))))

(define
  doc-update
  (fn
    (doc id field value)
    (doc-with-blocks
      doc
      (ct-replace-id (doc-blocks doc) id (fn (b) (blk-set b field value))))))

(define
  doc-delete
  (fn (doc id) (doc-with-blocks doc (ct-remove-id (doc-blocks doc) id))))

(define
  doc-move
  (fn
    (doc id i)
    (let
      ((blk (doc-find doc id)))
      (if
        (= blk nil)
        doc
        (doc-with-blocks
          doc
          (ct-insert-at (ct-remove-id (doc-blocks doc) id) i blk))))))

;; ── op constructors (data payload, reused by persist op log) ──
(define op-insert (fn (block after) {:after after :op "insert" :block block}))

(define op-update (fn (id field value) {:field field :id id :op "update" :value value}))

(define op-move (fn (id index) {:id id :op "move" :index index}))

(define op-delete (fn (id) {:id id :op "delete"}))

;; ── op interpreter ──
(define
  doc-apply
  (fn
    (doc op)
    (let
      ((kind (get op :op)))
      (cond
        ((= kind "insert")
          (doc-insert-after doc (get op :block) (get op :after)))
        ((= kind "update")
          (doc-update doc (get op :id) (get op :field) (get op :value)))
        ((= kind "move") (doc-move doc (get op :id) (get op :index)))
        ((= kind "delete") (doc-delete doc (get op :id)))
        (else (error (str "unknown op: " kind)))))))

(define
  doc-apply-all
  (fn
    (doc ops)
    (if
      (= (len ops) 0)
      doc
      (doc-apply-all (doc-apply doc (first ops)) (rest ops)))))

;; ── render-agnostic snapshot: list of (id . type) for assertions/debug ──
(define doc-ids (fn (doc) (map (fn (b) (blk-id b)) (doc-blocks doc))))

(define
  doc-types
  (fn (doc) (map (fn (b) (blk-type b)) (doc-blocks doc))))