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).
;;
;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
;; sections), since ids are unique across the tree. This keeps the persist
;; op-log, content/edit and content/find correct for nested documents.
;; insert/move are positional and act at the top level.
;;
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
;;
;; Op shapes (data, not objects — they are the persist event payload):
;;   {:op "insert" :block <blk> :after <id|nil>}   ; after nil = prepend (top level)
;;   {:op "update" :id <id> :field <name> :value <v>}   ; tree-wide by id
;;   {:op "move"   :id <id> :index <n>}                 ; top level
;;   {:op "delete" :id <id>}                            ; tree-wide by 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))))))

;; tree-wide remove by id: drop matches at this level, recurse into children
;; (blocks carrying a `children` list, i.e. sections).
(define
  ct-remove-id
  (fn
    (blocks id)
    (map
      (fn
        (b)
        (let
          ((ch (st-iv-get b "children")))
          (if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
      (filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))

;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
(define
  ct-replace-id
  (fn
    (blocks id f)
    (map
      (fn
        (b)
        (if
          (= (blk-id b) id)
          (f b)
          (let
            ((ch (st-iv-get b "children")))
            (if
              (list? ch)
              (st-iv-set! b "children" (ct-replace-id ch id f))
              b))))
      blocks)))

;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
(define
  ct-find-id
  (fn
    (blocks id)
    (if
      (= (len blocks) 0)
      nil
      (let
        ((b (first blocks)))
        (if
          (= (blk-id b) id)
          b
          (let
            ((ch (st-iv-get b "children")))
            (let
              ((nested (if (list? ch) (ct-find-id ch id) nil)))
              (if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))

;; ── 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)))

;; tree-wide lookup by id — reads a nested block by the same id content/edit can
;; update/delete (no section.sx dependency; uses the generic children descent).
(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))

(define
  doc-has-deep?
  (fn (doc id) (if (= (doc-find-deep doc id) nil) 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))))