rose-ash/lib/content/validate.sx

;; content-on-sx — document integrity validation.
;;
;; Guards imports, edits and federated input: walks the whole block TREE (into
;; nested sections) checking each block's id and required fields/types, plus
;; tree-wide duplicate ids. Returns issue dicts {:id :kind :detail}; empty = ok.
;; Tree detection is inline (class + st-iv-get) so this file needs no section.sx.
;; Dispatch on block type is a validation-boundary concern, not core behaviour.
;;
;; Collection blocks are vetted element-deep: list items must all be strings and
;; table rows must all be lists of strings — exactly what render/asText/
;; find-replace/search assume — so malformed nested collections are caught at the
;; boundary instead of crashing the render layer downstream.
;;
;; Requires (loaded by harness): block.sx, doc.sx.

(define ct-issue (fn (id kind detail) {:id id :detail detail :kind kind}))

(define
  ct-flatmap
  (fn
    (f xs)
    (if
      (= (len xs) 0)
      (list)
      (append (f (first xs)) (ct-flatmap f (rest xs))))))

(define ct-count-in (fn (x xs) (len (filter (fn (y) (= y x)) xs))))

;; dedup, order-preserving (keep first occurrence)
(define
  ct-uniq-loop
  (fn
    (xs seen)
    (if
      (= (len xs) 0)
      (reverse seen)
      (if
        (> (ct-count-in (first xs) seen) 0)
        (ct-uniq-loop (rest xs) seen)
        (ct-uniq-loop (rest xs) (cons (first xs) seen))))))

(define ct-uniq (fn (xs) (ct-uniq-loop xs (list))))

;; every element a string? / every row a list of strings? (for collection blocks)
(define
  ct-all-str?
  (fn
    (xs)
    (if
      (= (len xs) 0)
      true
      (if (string? (first xs)) (ct-all-str? (rest xs)) false))))

(define
  ct-all-rows?
  (fn
    (rows)
    (if
      (= (len rows) 0)
      true
      (if
        (if (list? (first rows)) (ct-all-str? (first rows)) false)
        (ct-all-rows? (rest rows))
        false))))

;; ── tree flatten (descends into CtSection children; guards malformed children) ──
(define
  ct-section-block?
  (fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
(define
  ct-tree-blocks
  (fn
    (blocks)
    (if
      (= (len blocks) 0)
      (list)
      (let
        ((b (first blocks)))
        (append
          (cons
            b
            (if
              (ct-section-block? b)
              (let
                ((ch (st-iv-get b "children")))
                (if (list? ch) (ct-tree-blocks ch) (list)))
              (list)))
          (ct-tree-blocks (rest blocks)))))))

;; ── id checks ──
(define
  content/-id-issues
  (fn
    (b)
    (let
      ((id (blk-id b)))
      (if
        (and (string? id) (> (len id) 0))
        (list)
        (list (ct-issue id "id" "block id must be a non-empty string"))))))

(define
  ct-field-issue
  (fn (id ok? what) (if ok? (list) (list (ct-issue id "field" what)))))

;; ── per-type field checks ──
(define
  content/-field-issues
  (fn
    (b)
    (let
      ((t (blk-type b)) (id (blk-id b)))
      (cond
        ((= t "heading")
          (append
            (ct-field-issue
              id
              (number? (blk-get b "level"))
              "heading level must be a number")
            (ct-field-issue
              id
              (string? (blk-get b "text"))
              "heading text must be a string")))
        ((= t "text")
          (ct-field-issue
            id
            (string? (blk-get b "text"))
            "text must be a string"))
        ((= t "code")
          (append
            (ct-field-issue
              id
              (string? (blk-get b "language"))
              "code language must be a string")
            (ct-field-issue
              id
              (string? (blk-get b "text"))
              "code text must be a string")))
        ((= t "quote")
          (ct-field-issue
            id
            (string? (blk-get b "text"))
            "quote text must be a string"))
        ((= t "image")
          (append
            (ct-field-issue
              id
              (string? (blk-get b "src"))
              "image src must be a string")
            (ct-field-issue
              id
              (string? (blk-get b "alt"))
              "image alt must be a string")))
        ((= t "embed")
          (append
            (ct-field-issue
              id
              (string? (blk-get b "url"))
              "embed url must be a string")
            (ct-field-issue
              id
              (string? (blk-get b "provider"))
              "embed provider must be a string")))
        ((= t "divider") (list))
        ((= t "list")
          (let
            ((items (blk-get b "items")))
            (append
              (ct-field-issue
                id
                (boolean? (blk-get b "ordered"))
                "list ordered must be a boolean")
              (append
                (ct-field-issue id (list? items) "list items must be a list")
                (ct-field-issue
                  id
                  (if (list? items) (ct-all-str? items) true)
                  "list items must all be strings")))))
        ((= t "section")
          (ct-field-issue
            id
            (list? (blk-get b "children"))
            "section children must be a list"))
        ((= t "table")
          (let
            ((headers (blk-get b "headers")) (rows (blk-get b "rows")))
            (append
              (append
                (ct-field-issue
                  id
                  (list? headers)
                  "table headers must be a list")
                (ct-field-issue
                  id
                  (if (list? headers) (ct-all-str? headers) true)
                  "table headers must all be strings"))
              (append
                (ct-field-issue id (list? rows) "table rows must be a list")
                (ct-field-issue
                  id
                  (if (list? rows) (ct-all-rows? rows) true)
                  "table rows must all be lists of strings")))))
        ((= t "callout")
          (append
            (ct-field-issue
              id
              (string? (blk-get b "kind"))
              "callout kind must be a string")
            (ct-field-issue
              id
              (string? (blk-get b "text"))
              "callout text must be a string")))
        ((= t "media")
          (append
            (ct-field-issue
              id
              (if
                (= (blk-get b "kind") "video")
                true
                (= (blk-get b "kind") "audio"))
              "media kind must be video or audio")
            (ct-field-issue
              id
              (string? (blk-get b "src"))
              "media src must be a string")))
        (else (list (ct-issue id "type" (str "unknown block type: " t))))))))

(define
  content/-block-issues
  (fn (b) (append (content/-id-issues b) (content/-field-issues b))))

;; ── duplicate ids across the whole tree ──
(define
  content/-dup-issues
  (fn
    (ids)
    (map
      (fn (id) (ct-issue id "duplicate" (str "duplicate block id: " id)))
      (ct-uniq (filter (fn (id) (> (ct-count-in id ids) 1)) ids)))))

;; ── public ──
(define
  content/validate
  (fn
    (doc)
    (let
      ((all (ct-tree-blocks (doc-blocks doc))))
      (append
        (content/-dup-issues (map (fn (b) (blk-id b)) all))
        (ct-flatmap content/-block-issues all)))))

(define
  content/valid?
  (fn (doc) (= (len (content/validate doc)) 0)))

(define
  content/issue-kinds
  (fn (doc) (map (fn (i) (get i :kind)) (content/validate doc))))