rose-ash/lib/content/block.sx

;; content-on-sx — typed block objects on Smalltalk-on-SX.
;;
;; A block is a Smalltalk instance. Behaviour (type tag, later render) is a
;; message, not a property switch. Fields are immutable: blk-set / mk-* build a
;; fresh instance via the functional st-iv-set!, so old versions are never
;; clobbered (history-safe for the persist op log and CRDT merge).
;;
;; Hierarchy:
;;   CtBlock (id)
;;     CtText (text)
;;       CtHeading (level)
;;       CtCode (language)
;;       CtQuote (cite)
;;     CtImage (src alt)
;;     CtEmbed (url provider)
;;     CtDivider
;;     CtList (ordered items)
;; Plus self-contained blocks registered by their own files: CtSection,
;; CtTable, CtCallout, CtMedia. ct-class-for-type maps every tag (so mk-block,
;; content/from-data and CRDT materialise build them uniformly); the classes
;; themselves are registered by content-bootstrap-section!/table!/callout!/media!.

(define
  ct-def-method!
  (fn (cls sel src) (st-class-add-method! cls sel (st-parse-method src))))

;; Register the block hierarchy in the Smalltalk class table. Call AFTER
;; st-bootstrap-classes! (which resets the table). Idempotent.
(define
  content-bootstrap-blocks!
  (fn
    ()
    (begin
      (st-class-define! "CtBlock" "Object" (list "id"))
      (ct-def-method! "CtBlock" "id" "id ^ id")
      (ct-def-method! "CtBlock" "type" "type ^ #block")
      (ct-def-method! "CtBlock" "isBlock" "isBlock ^ true")
      (st-class-define! "CtText" "CtBlock" (list "text"))
      (ct-def-method! "CtText" "text" "text ^ text")
      (ct-def-method! "CtText" "type" "type ^ #text")
      (st-class-define! "CtHeading" "CtText" (list "level"))
      (ct-def-method! "CtHeading" "level" "level ^ level")
      (ct-def-method! "CtHeading" "type" "type ^ #heading")
      (st-class-define! "CtCode" "CtText" (list "language"))
      (ct-def-method! "CtCode" "language" "language ^ language")
      (ct-def-method! "CtCode" "type" "type ^ #code")
      (st-class-define! "CtQuote" "CtText" (list "cite"))
      (ct-def-method! "CtQuote" "cite" "cite ^ cite")
      (ct-def-method! "CtQuote" "type" "type ^ #quote")
      (st-class-define! "CtImage" "CtBlock" (list "src" "alt"))
      (ct-def-method! "CtImage" "src" "src ^ src")
      (ct-def-method! "CtImage" "alt" "alt ^ alt")
      (ct-def-method! "CtImage" "type" "type ^ #image")
      (st-class-define! "CtEmbed" "CtBlock" (list "url" "provider"))
      (ct-def-method! "CtEmbed" "url" "url ^ url")
      (ct-def-method! "CtEmbed" "provider" "provider ^ provider")
      (ct-def-method! "CtEmbed" "type" "type ^ #embed")
      (st-class-define! "CtDivider" "CtBlock" (list))
      (ct-def-method! "CtDivider" "type" "type ^ #divider")
      (st-class-define! "CtList" "CtBlock" (list "ordered" "items"))
      (ct-def-method! "CtList" "ordered" "ordered ^ ordered")
      (ct-def-method! "CtList" "items" "items ^ items")
      (ct-def-method! "CtList" "type" "type ^ #list")
      true)))

;; Apply (name value) pairs functionally onto a fresh instance.
(define
  ct-apply-fields
  (fn
    (inst pairs)
    (if
      (= (len pairs) 0)
      inst
      (ct-apply-fields
        (st-iv-set!
          inst
          (first (first pairs))
          (first (rest (first pairs))))
        (rest pairs)))))

(define
  ct-class-for-type
  (fn
    (tag)
    (cond
      ((= tag "text") "CtText")
      ((= tag "heading") "CtHeading")
      ((= tag "code") "CtCode")
      ((= tag "quote") "CtQuote")
      ((= tag "image") "CtImage")
      ((= tag "embed") "CtEmbed")
      ((= tag "divider") "CtDivider")
      ((= tag "list") "CtList")
      ((= tag "section") "CtSection")
      ((= tag "table") "CtTable")
      ((= tag "callout") "CtCallout")
      ((= tag "media") "CtMedia")
      (else (error (str "unknown block type: " tag))))))

;; Generic constructor — wire tag + id + (name value) field pairs.
(define
  mk-block
  (fn
    (type-tag id fields)
    (ct-apply-fields
      (st-iv-set! (st-make-instance (ct-class-for-type type-tag)) "id" id)
      fields)))

(define
  mk-text
  (fn (id text) (mk-block "text" id (list (list "text" text)))))

(define
  mk-heading
  (fn
    (id level text)
    (mk-block "heading" id (list (list "level" level) (list "text" text)))))

(define
  mk-code
  (fn
    (id language text)
    (mk-block
      "code"
      id
      (list (list "language" language) (list "text" text)))))

(define
  mk-quote
  (fn
    (id cite text)
    (mk-block "quote" id (list (list "cite" cite) (list "text" text)))))

(define
  mk-image
  (fn
    (id src alt)
    (mk-block "image" id (list (list "src" src) (list "alt" alt)))))

(define
  mk-embed
  (fn
    (id url provider)
    (mk-block "embed" id (list (list "url" url) (list "provider" provider)))))

(define mk-divider (fn (id) (mk-block "divider" id (list))))

(define
  mk-list
  (fn
    (id ordered items)
    (mk-block
      "list"
      id
      (list (list "ordered" ordered) (list "items" items)))))

;; Accessors. blk-type / blk-id go through message dispatch (polymorphic);
;; blk-get reads any ivar directly; blk-set is copy-on-write.
(define blk-id (fn (b) (st-send b "id" (list))))
(define blk-type (fn (b) (str (st-send b "type" (list)))))
(define blk-send (fn (b sel) (st-send b sel (list))))
(define blk-get (fn (b field) (st-iv-get b field)))
(define blk-set (fn (b field val) (st-iv-set! b field val)))

(define
  block?
  (fn
    (v)
    (and
      (st-instance? v)
      (st-class-inherits-from? (get v :class) "CtBlock"))))