cl-tty/src/components/markdown.lisp

;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty

(in-package :cl-tty.markdown)

(defun make-md-node (type &key children properties content url)
  (let ((node (list :type type)))
    (when children (setf (getf node :children) children))
    (when properties (setf (getf node :properties) properties))
    (when content (setf (getf node :content) content))
    (when url (setf (getf node :url) url))
    node))

(defun md-node-p (thing)
  (and (listp thing) (getf thing :type)))

(defun md-node-text (node)
  (let ((type (getf node :type)))
    (cond ((eql type :text) (or (getf node :content) ""))
          ((eql type :link)
           (concatenate 'string
                        (md-node-text (first (getf node :children)))
                        (format nil " (~a)" (or (getf node :url) ""))))
          ((eql type :inline-code) (or (getf node :content) ""))
          ((getf node :children)
           (apply #'concatenate 'string
                  (mapcar #'md-node-text (getf node :children))))
          (t ""))))

(defun split-string-into-lines (string)
  (unless string (return-from split-string-into-lines (coerce nil 'vector)))
  (let ((result nil) (start 0))
    (flet ((add-line (end) (push (subseq string start end) result)))
      (loop for i from 0 below (length string)
            do (let ((c (char string i)))
                 (cond ((char= c #\Newline) (add-line i) (setf start (1+ i)))
                       ((and (char= c #\Return) (< (1+ i) (length string))
                             (char= (char string (1+ i)) #\Newline))
                        (add-line i) (setf start (+ i 2)) (incf i)))))
      (when (< start (length string)) (add-line (length string)))
      (coerce (nreverse result) 'vector))))

(defun classify-line (line)
  (cond
    ((string= line "") (cons :blank nil))
    ((and (>= (length line) 3)
          (let ((c0 (char line 0)))
            (and (find c0 "-*")
                 (every (lambda (c) (or (char= c c0) (char= c #\Space) (char= c #\Tab)))
                        line))))
     (cons :thematic-break nil))
    ((and (char= (char line 0) #\#)
          (let ((count 0))
            (loop for c across line while (char= c #\#) do (incf count))
            (and (<= 1 count 6)
                 (or (>= (length line) (1+ count))
                     (member (char line count) '(#\Space #\Tab))))))
     (let* ((hash-count (loop for c across line while (char= c #\#) count c))
            (content (string-trim (list #\Space #\Tab) (subseq line hash-count))))
       (cons :heading (cons hash-count content))))
    ((char= (char line 0) #\>)
     (cons :blockquote (string-trim (list #\Space #\Tab) (subseq line 1))))
    ((and (>= (length line) 2) (find (char line 0) "-*+")
          (char= (char line 1) #\Space))
     (cons :list-item (string-trim (list #\Space #\Tab) (subseq line 2))))
    ((and (>= (length line) 3) (digit-char-p (char line 0))
          (loop for c across line while (digit-char-p c)
                finally (return (find c ". )"))))
     (let ((dot-pos (position-if (lambda (c) (find c ". )")) line)))
       (if (and dot-pos (find (char line dot-pos) ". )"))
           (cons :ordered-item (string-trim (list #\Space #\Tab)
                                            (subseq line (1+ dot-pos))))
           (cons :paragraph line))))
    ((and (>= (length line) 4) (find (char line 0) "-+")
          (char= (char line 1) (char line 0))
          (char= (char line 2) (char line 0))
          (char= (char line 3) #\Space))
     (cons :diff-header line))
    ((and (>= (length line) 1) (find (char line 0) "-+")
          (not (and (>= (length line) 3)
                    (char= (char line 1) (char line 0))
                    (char= (char line 2) (char line 0)))))
     (cons :diff-line (cons (char line 0) (subseq line 1))))
    ((and (>= (length line) 3) (find (char line 0) "`~")
          (let ((fence-len (loop for c across line
                                 while (char= c (char line 0)) count c)))
            (and (>= fence-len 3)
                 (let ((rest (string-trim (list #\Space #\Tab)
                                         (subseq line fence-len))))
                   (cons :code-start rest))))))
    (t (cons :paragraph line))))

(defun find-closing-marker (text start marker)
  (let ((marker-len (length marker)) (len (length text)))
    (loop for j from start to (- len marker-len)
          do (when (and (char= (char text j) (char marker 0))
                        (string= marker (subseq text j (+ j marker-len)))
                        (or (= j 0) (not (char= (char text (1- j)) #\\))))
               (return j))
          finally (return nil))))

(defun parse-paragraph (lines start)
  (let ((text-parts nil) (i start))
    (loop while (< i (length lines))
          do (let* ((raw-line (aref lines i))
                    (line (string-trim (list #\return) raw-line))
                    (class (classify-line line)))
               (case (car class)
                 ((:paragraph) (push (cdr class) text-parts) (incf i))
                 (:blank (incf i) (loop-finish))
                 (t (loop-finish)))))
    (values (make-md-node :paragraph :children
                          (parse-inline
                           (with-output-to-string (s)
                             (loop for part in (nreverse text-parts)
                                   for first = t then nil
                                   do (unless first (write-char #\Space s))
                                   (princ part s)))))
            i)))

(defun parse-blockquote (lines start)
  (let ((text-parts nil) (i start))
    (loop while (< i (length lines))
          do (let* ((raw-line (aref lines i))
                    (line (string-trim (list #\return) raw-line))
                    (class (classify-line line)))
               (case (car class)
                 (:blockquote (push (cdr class) text-parts) (incf i))
                 (:blank (incf i) (loop-finish))
                 (t (loop-finish)))))
    (values (make-md-node :blockquote :children
                          (parse-inline
                           (with-output-to-string (s)
                             (loop for part in (nreverse text-parts)
                                   for first = t then nil
                                   do (unless first (write-char #\Space s))
                                   (princ part s)))))
            i)))

(defun parse-list (lines start)
  (let ((items nil) (i start))
    (loop while (< i (length lines))
          do (let* ((raw-line (aref lines i))
                    (line (string-trim (list #\return) raw-line))
                    (class (classify-line line)))
           (case (car class)
                 ((:list-item :ordered-item)
                  (push (cons (car class) (cdr class)) items) (incf i))
                 (:blank
                  (if (and (< (1+ i) (length lines))
                           (let ((nc (classify-line
                                      (string-trim (list #\return)
                                                   (aref lines (1+ i))))))
                             (member (car nc) '(:list-item :ordered-item))))
                      (progn (push (cons :blank-sep nil) items) (incf i))
                      (progn (incf i) (loop-finish))))
                 (t (loop-finish)))))
    (let ((nodes nil))
      (dolist (item (nreverse items))
        (let ((type (car item)) (content (cdr item)))
          (when (and content (not (string= content "")))
            (push (make-md-node type :children (parse-inline content)) nodes))))
      (values (nreverse nodes) i))))

(defun parse-code-block (lines start lang)
  (let ((code-lines nil)
        (i (1+ start))
        (fence-char (char (aref lines start) 0))
        (fence-len (loop for c across (aref lines start)
                         while (char= c (char (aref lines start) 0)) count c)))
    (loop while (< i (length lines))
          do (let* ((raw-line (aref lines i))
                    (line (string-trim (list #\return) raw-line)))
               (when (and (>= (length line) fence-len)
                          (every (lambda (c) (char= c fence-char))
                                 (subseq line 0 fence-len))
                          (or (= (length line) fence-len)
                              (every (lambda (c) (find c " \t"))
                                     (subseq line fence-len))))
                 (incf i) (loop-finish))
               (push line code-lines)
               (incf i)))
    (values (make-md-node :code-block
                          :properties (list :language (and lang (not (string= lang "")) lang))
                          :content
                          (with-output-to-string (s)
                            (loop for cl in (nreverse code-lines)
                                  for first = t then nil
                                  do (unless first (terpri s)) (princ cl s))))
            i)))

(defun parse-diff-block (lines start)
  (let ((diff-lines nil) (i start))
    (loop while (< i (length lines))
          do (let* ((raw-line (aref lines i))
                    (line (string-trim (list #\return) raw-line))
                    (class (classify-line line)))
               (case (car class)
                 ((:diff-header :diff-line) (push line diff-lines) (incf i))
                 (:blank (incf i) (loop-finish))
                 (t (loop-finish)))))
    (let ((lines-list (nreverse diff-lines)))
      (values (make-md-node :diff-block
                            :content
                            (with-output-to-string (s)
                              (loop for dl in lines-list
                                    for first = t then nil
                                    do (unless first (terpri s)) (princ dl s)))
                            :properties (list :lines lines-list))
              i))))

(defun parse-blocks (text)
  (unless text (return-from parse-blocks nil))
  (let ((lines (split-string-into-lines text)) (nodes nil) (i 0))
    (loop while (< i (length lines))
          do (let* ((line (string-trim (list #\return) (aref lines i)))
                    (classification (classify-line line)))
               (case (car classification)
                 (:blank (incf i))
                 (:thematic-break (push (make-md-node :thematic-break) nodes) (incf i))
                 (:paragraph
                  (multiple-value-bind (node consumed) (parse-paragraph lines i)
                    (push node nodes) (setf i consumed)))
                 (:heading
                  (let* ((level+content (cdr classification))
                         (level (car level+content))
                         (content (cdr level+content)))
                    (push (make-md-node :heading :properties (list :level level)
                                        :children (parse-inline content)) nodes)
                    (incf i)))
                 (:blockquote
                  (multiple-value-bind (node consumed) (parse-blockquote lines i)
                    (push node nodes) (setf i consumed)))
                 (:list-item
                  (multiple-value-bind (node consumed) (parse-list lines i)
                    (dolist (n node) (push n nodes)) (setf i consumed)))
                 (:ordered-item
                  (multiple-value-bind (node consumed) (parse-list lines i)
                    (dolist (n node) (push n nodes)) (setf i consumed)))
                 (:code-start
                  (multiple-value-bind (node consumed)
                      (parse-code-block lines i (cdr classification))
                    (push node nodes) (setf i consumed)))
                 (:diff-header
                  (multiple-value-bind (node consumed) (parse-diff-block lines i)
                    (push node nodes) (setf i consumed)))
                 (t (incf i)))))
    (nreverse nodes)))

(defun parse-inline (text)
  (unless (and text (> (length text) 0)) (return-from parse-inline nil))
  (let ((nodes nil) (i 0) (len (length text)))
    (loop while (< i len)
          do (let ((c (char text i)))
               (case c
                 (#\*
                  (multiple-value-bind (node consumed) (parse-star-emphasis text i len)
                    (if node (progn (push node nodes) (setf i consumed))
                        (progn (push (make-md-node :text :content (string c)) nodes) (incf i)))))
                 (#\_
                  (multiple-value-bind (node consumed) (parse-underscore-emphasis text i len)
                    (if node (progn (push node nodes) (setf i consumed))
                        (progn (push (make-md-node :text :content (string c)) nodes) (incf i)))))
                 (#\`
                  (multiple-value-bind (node consumed) (parse-inline-code text i len)
                    (if node (progn (push node nodes) (setf i consumed))
                        (progn (push (make-md-node :text :content (string c)) nodes) (incf i)))))
                 (#\[
                  (multiple-value-bind (node consumed) (parse-link text i len)
                    (if node (progn (push node nodes) (setf i consumed))
                        (progn (push (make-md-node :text :content (string c)) nodes) (incf i)))))
                 (t (let ((start i))
                      (incf i)
                      (loop while (< i len)
                            do (let ((nc (char text i)))
                                 (if (find nc "*_`[") (loop-finish)
                                     (progn
                                       (when (and (< (1+ i) len)
                                                  (find nc "*_")
                                                  (char= nc (char text (1+ i))))
                                         (loop-finish))
                                       (incf i)))))
                      (push (make-md-node :text :content (subseq text start i)) nodes))))))
    (nreverse nodes)))

(defun parse-star-emphasis (text i len)
  (when (>= i len) (return-from parse-star-emphasis (values nil i)))
  (if (and (< (1+ i) len) (char= (char text (1+ i)) #\*))
      (let ((close (find-closing-marker text (+ i 2) "**")))
        (if close
            (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close)))
                    (+ close 2))
            (values nil i)))
      (let ((close (find-closing-marker text (1+ i) "*")))
        (if close
            (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close)))
                    (1+ close))
            (values nil i)))))

(defun parse-underscore-emphasis (text i len)
  (when (>= i len) (return-from parse-underscore-emphasis (values nil i)))
  (when (and (> i 0) (not (find (char text (1- i)) " \t\n\r")))
    (return-from parse-underscore-emphasis (values nil i)))
  (if (and (< (1+ i) len) (char= (char text (1+ i)) #\_))
      (let ((close (find-closing-marker text (+ i 2) "__")))
        (if close
            (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close)))
                    (+ close 2))
            (values nil i)))
      (let ((close (find-closing-marker text (1+ i) "_")))
        (if (and close
                 (or (>= (1+ close) len)
                     (find (char text (1+ close)) " \t\n\r.,;:!?")))
            (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close)))
                    (1+ close))
            (values nil i)))))

(defun parse-inline-code (text i len)
  (when (or (>= i len) (not (char= (char text i) #\`)))
    (return-from parse-inline-code (values nil i)))
  (let ((bt-count (loop for j from i below (min len (+ i 3))
                        while (char= (char text j) #\`) count j)))
    (let ((close (find-closing-marker text (+ i bt-count)
                                      (make-string bt-count :initial-element #\`))))
      (if close
          (values (make-md-node :inline-code
                                :content (subseq text (+ i bt-count) close))
                  (+ close bt-count))
          (values nil i)))))

(defun parse-link (text i len)
  (when (or (>= i len) (not (char= (char text i) #\[)))
    (return-from parse-link (values nil i)))
  (let ((close-bracket (find-closing-marker text (1+ i) "]")))
    (unless close-bracket (return-from parse-link (values nil i)))
    (when (or (>= (1+ close-bracket) len)
              (not (char= (char text (1+ close-bracket)) #\()))
      (return-from parse-link (values nil i)))
    (let ((close-paren (find-closing-marker text (+ close-bracket 2) ")")))
      (unless close-paren (return-from parse-link (values nil i)))
      (values (make-md-node :link
                            :children (parse-inline (subseq text (1+ i) close-bracket))
                            :url (subseq text (+ close-bracket 2) close-paren))
              (1+ close-paren)))))

(defun get-highlighter (lang)
  (cdr (assoc lang
              '(("lisp"    . (:comment (";" "#|" ";;") :string ("\"")
                             :keyword ("defun" "defmacro" "defmethod" "defgeneric"
                                       "defvar" "defparameter" "defconstant" "defstruct"
                                       "defclass" "deftype" "define-condition"
                                       "let" "let*" "flet" "labels" "macrolet"
                                       "if" "when" "unless" "cond" "case" "ecase" "typecase"
                                       "loop" "do" "dolist" "dotimes" "tagbody" "go"
                                       "block" "return" "return-from"
                                       "progn" "prog1" "prog2"
                                       "lambda" "function" "quote"
                                       "setf" "setq" "push" "pop" "incf" "decf"
                                       "in-package" "defpackage" "export" "import"
                                       "handler-case" "handler-bind" "ignore-errors"
                                       "multiple-value-bind" "multiple-value-call"
                                       "destructuring-bind"
                                       "declare" "the" "values"
                                       "and" "or" "not" "null"
                                       "car" "cdr" "first" "rest" "second"
                                       "cons" "list" "append" "nconc"
                                       "mapcar" "mapc" "reduce"
                                       "find" "position" "count" "subseq"
                                       "format" "princ" "print" "write" "read"
                                       "load" "compile" "eval"
                                       "make-instance" "slot-value"
                                       "type-of" "class-of")
                             :builtin ("t" "nil"
                                       "*standard-output*" "*standard-input*"
                                       "*error-output*" "*debug-io*"
                                       "*package*" "*print-circle*")))

                ("common-lisp" . (:comment (";" "#|" ";;") :string ("\"")
                                 :keyword ("defun" "defmacro" "defmethod" "defgeneric"
                                           "let" "if" "when" "unless" "cond" "case"
                                           "loop" "do" "dolist" "dotimes"
                                           "return" "return-from" "block"
                                           "lambda" "function" "quote"
                                           "setf" "setq" "push" "pop" "incf" "decf"
                                           "handler-case" "handler-bind"
                                           "declare" "the" "values"
                                           "defpackage" "in-package" "export" "import"
                                           "error" "warn" "assert"
                                           "car" "cdr" "first" "rest"
                                           "cons" "list" "append" "mapcar" "reduce"
                                           "format" "princ" "print" "read" "load"
                                           "make-instance")
                                 :builtin ("t" "nil")))

                ("python"  . (:comment ("#") :string ("\"" "'" "\"\"\"" "'''")
                             :keyword ("def" "class" "return" "yield" "import" "from"
                                       "if" "elif" "else" "for" "while" "in" "not"
                                       "try" "except" "finally" "raise" "with" "pass"
                                       "break" "continue" "lambda" "global"
                                       "assert" "del" "is"
                                       "self" "cls" "async" "await")
                             :builtin ("None" "True" "False")))

                ("javascript" . (:comment ("//" "/*") :string ("\"" "'" "`")
                                :keyword ("function" "class" "const" "let" "var"
                                          "if" "else" "for" "while" "do" "switch"
                                          "return" "break" "continue"
                                          "try" "catch" "finally" "throw"
                                          "new" "this" "super" "delete" "typeof"
                                          "import" "export" "from" "default"
                                          "async" "await" "yield" "of")
                                :builtin ("true" "false" "null" "undefined" "NaN")))

                ("bash"    . (:comment ("#") :string ("\"" "'")
                             :keyword ("if" "then" "else" "elif" "fi" "for" "while"
                                       "done" "case" "esac" "in" "function" "return"
                                       "export" "local" "unset" "source"
                                       "echo" "printf" "read" "test" "let" "declare")
                             :builtin ("true" "false" "cd" "ls" "cat" "grep" "sed"
                                       "mv" "cp" "rm" "mkdir" "touch" "find" "wc"
                                       "head" "tail" "date" "sleep" "kill")))

                ("shell"   . (:comment ("#") :string ("\"" "'")
                             :keyword ("if" "then" "else" "elif" "fi" "for" "while"
                                       "done" "case" "esac" "in" "function" "return"
                                       "export" "local" "unset" "source"
                                       "echo" "printf" "read" "test")
                             :builtin ("true" "false" "cd" "ls" "grep" "sed"
                                       "mv" "cp" "rm" "mkdir" "touch" "find"))))
              :test #'string=)))

(defun tokenize-line (line highlighter)
  (let ((tokens nil) (i 0) (len (length line))
        (comment-chars (getf highlighter :comment))
        (string-chars (getf highlighter :string))
        (keywords (getf highlighter :keyword))
        (builtins (getf highlighter :builtin)))
    (loop while (< i len)
          do (let ((c (char line i)))
               (cond
                 ((find c " \t")
                  (let ((start i))
                    (loop while (and (< i len) (find (char line i) " \t")) do (incf i))
                    (push (cons (subseq line start i) :plain) tokens)))
                 ((and comment-chars
                       (some (lambda (cc)
                               (and (<= (+ i (length cc)) len)
                                    (string= cc (subseq line i (+ i (length cc))))))
                             comment-chars))
                  (push (cons (subseq line i) :comment) tokens) (setf i len))
                 ((and string-chars (some (lambda (s) (find c s)) string-chars))
                  (let ((start i))
                    (incf i)
                    (let ((triple (and (< i (1- len)) (char= (char line i) c)
                                       (char= (char line (1+ i)) c))))
                      (if triple
                          (progn (incf i 2)
                                 (loop while (and (< i len)
                                                 (not (and (char= (char line i) c)
                                                           (< (1+ i) len)
                                                           (char= (char line (1+ i)) c)
                                                           (< (+ i 2) len)
                                                           (char= (char line (+ i 2)) c))))
                                       do (incf i))
                                 (incf i 3))
                          (progn (loop while (and (< i len) (char/= (char line i) c))
                                       do (incf i))
                                 (when (< i len) (incf i)))))
                    (push (cons (subseq line start i) :string) tokens)))
                 ((or (digit-char-p c)
                      (and (find c "+-") (< (1+ i) len) (digit-char-p (char line (1+ i)))))
                  (let ((start i))
                    (loop while (and (< i len) (not (find (char line i) " \t()[]{}'\";:#")))
                          do (incf i))
                    (let ((token (subseq line start i)))
                      (if (digit-char-p (char token 0))
                          (push (cons token :number) tokens)
                          (push (cons token :plain) tokens)))))
                 ((or (alpha-char-p c)
                      (and (find c "-_?!*<>=") (> len 1)))
                  (let ((start i))
                    (loop while (and (< i len)
                                    (or (alphanumericp (char line i))
                                        (find (char line i) "-_?!*<>=")))
                          do (incf i))
                    (let* ((token (subseq line start i))
                          (down (string-downcase token)))
                      (cond
                        ((find down keywords :test #'string=)
                         (push (cons token :keyword) tokens))
                        ((find down builtins :test #'string=)
                         (push (cons token :builtin) tokens))
                        (t (if (and (< i len) (char= (char line i) #\())
                               (push (cons token :function) tokens)
                               (push (cons token :plain) tokens)))))))
                 (t (push (cons (string c) :plain) tokens) (incf i)))))
    (nreverse tokens)))

(defun highlight-code (code language)
  (unless code (return-from highlight-code nil))
  (let ((highlighter (get-highlighter (and language (string-downcase language)))))
    (unless highlighter (return-from highlight-code (list (cons code :plain))))
    (let ((tokens nil))
      (with-input-from-string (stream code)
        (loop for line = (read-line stream nil nil) while line
              do (let ((line-tokens (tokenize-line line highlighter)))
                   (when tokens (push (cons (string #\Newline) :plain) tokens))
                   (setf tokens (nconc (nreverse line-tokens) tokens)))))
      (nreverse tokens))))

(defun apply-highlight-token (token category)
  (let ((code (case category
                (:keyword "33") (:builtin "36")
                (:function "34") (:comment "2") (:string "32") (:number "35")
                (t nil))))
    (if code (format nil "~c[~am~a~c[0m" #\Esc code token #\Esc) token)))

(defun apply-highlight-style (char-vector)
  (coerce char-vector 'string))

(defun string-prefix-p (prefix string)
  (and (>= (length string) (length prefix))
       (string= prefix (subseq string 0 (length prefix)))))

(defun classify-diff-line (line)
  (cond ((string-prefix-p "+++ " line) :file-header)
        ((string-prefix-p "--- " line) :file-header)
        ((string-prefix-p "@@" line) :hunk-header)
        ((string-prefix-p "+" line) :added)
        ((string-prefix-p "-" line) :removed)
        (t :context)))

(defun apply-style (style text)
  (let ((code (cond
               ((eql style :bold) "1") ((eql style :italic) "3")
               ((eql style :dim) "2") ((eql style :code) "0")
               ((eql style :link) "4;36") ((eql style :url) "4;2")
               ((eql style :underline) "4") ((eql style :strike) "9")
               ((eql style :black) "30") ((eql style :red) "31")
               ((eql style :green) "32") ((eql style :yellow) "33")
               ((eql style :blue) "34") ((eql style :magenta) "35")
               ((eql style :cyan) "36") ((eql style :white) "37")
               ((eql style :bright-black) "90") ((eql style :bright-red) "91")
               ((eql style :bright-green) "92") ((eql style :bright-yellow) "93")
               ((eql style :bright-blue) "94") ((eql style :bright-magenta) "95")
               ((eql style :bright-cyan) "96") ((eql style :bright-white) "97")
               ((string= style "bold") "1") ((string= style "italic") "3")
               ((string= style "dim") "2") ((string= style "code") "0")
               ((string= style "link") "4;36") ((string= style "url") "4;2")
               ((string= style "bright-cyan") "96")
               ((string= style "bright-yellow") "93")
               ((string= style "bright-white") "97")
               ((string= style "bright-red") "91")
               ((string= style "bright-green") "92")
               ((string= style "bright-blue") "94")
               ((string= style "bright-magenta") "95")
               ((string= style "cyan") "36") ((string= style "yellow") "33")
               ((string= style "red") "31") ((string= style "green") "32")
               ((string= style "blue") "34") ((string= style "magenta") "35")
               ((string= style "white") "37") ((string= style "black") "30")
               (t nil))))
    (if code (format nil "~c[~am~a~c[0m" #\Esc code text #\Esc) text)))

(defun render-inline (children)
  (if (null children) ""
      (with-output-to-string (s)
        (dolist (child children)
          (let ((type (getf child :type)))
            (case type
              (:text (princ (or (getf child :content) "") s))
              (:bold (princ (apply-style :bold (render-inline (getf child :children))) s))
              (:italic (princ (apply-style :italic (render-inline (getf child :children))) s))
              (:inline-code (princ (apply-style :code (or (getf child :content) "")) s))
              (:link (let ((text (render-inline (getf child :children)))
                           (url (or (getf child :url) "")))
                       (princ (apply-style :link text) s)
                       (when (and url (not (string= url "")))
                         (princ " " s)
                         (princ (apply-style :url (format nil "(~a)" url)) s))))
              (t (princ (or (getf child :content) "") s))))))))

(defun render-heading (node)
  (let* ((level (or (getf (getf node :properties) :level) 1))
         (prefix (make-string (min level 6) :initial-element #\#))
         (text (render-inline (getf node :children)))
         (color (cond ((= level 1) :bright-cyan) ((= level 2) :bright-yellow)
                      (t :bright-white))))
    (list (apply-style color (concatenate 'string prefix " " text)))))

(defun render-paragraph (node)
  (list (render-inline (getf node :children))))

(defun render-blockquote (node)
  (list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children))))))

(defun render-code-block (node)
  (let* ((language (or (getf (getf node :properties) :language) ""))
         (content (or (getf node :content) ""))
         (highlighted (unless (or (null language) (string= language ""))
                        (highlight-code content language)))
         (lines nil))
    (when (and language (not (string= language "")))
      (push (apply-style :dim (format nil "  ~~~~~~ ~a" language)) lines))
    (if highlighted
        (let ((cl (make-array 0 :element-type 'character
                              :fill-pointer 0 :adjustable t))
              (output nil))
          (dolist (pair highlighted)
            (let ((token (car pair)) (category (cdr pair)))
              (cond ((string= token (string #\Newline))
                     (push (apply-highlight-style cl) output)
                     (setf cl (make-array 0 :element-type 'character
                                          :fill-pointer 0 :adjustable t)))
                    (t (let ((colored (apply-highlight-token token category)))
                         (loop for ch across colored
                               do (vector-push-extend ch cl)))))))
          (when (> (length cl) 0) (push (apply-highlight-style cl) output))
          (setf lines (nconc lines (nreverse output))))
        (with-input-from-string (s content)
          (loop for line = (read-line s nil nil) while line
                do (push (apply-style :code line) lines))))
    (nreverse lines)))

(defun render-diff-block (node)
  (let* ((lines (getf (getf node :properties) :lines)) (result nil))
    (dolist (line (or lines
                      (and (getf node :content)
                           (let ((l (split-string-into-lines (getf node :content))))
                             (loop for i from 0 below (length l) collect (aref l i))))))
      (let* ((class (classify-diff-line line))
             (color (case class
                      (:added "32") (:removed "31")
                      (:hunk-header "36") (:file-header "1;36") (t nil))))
        (if color
            (push (format nil "~c[~am~a~c[0m" #\Esc color line #\Esc) result)
            (push line result))))
    (nreverse result)))

(defun render-thematic-break (node)
  (declare (ignore node))
  (list (apply-style :dim "──────────────────────────────────────────────")))

(defun render-list-item (node)
  (list (concatenate 'string
                     (if (eql (getf node :type) :ordered-item) " 1." " * ")
                     (render-inline (getf node :children)))))

(defun render-md-node (node)
  (let ((type (getf node :type)))
    (case type
      (:heading (render-heading node))
      (:paragraph (render-paragraph node))
      (:blockquote (render-blockquote node))
      (:code-block (render-code-block node))
      (:diff-block (render-diff-block node))
      (:thematic-break (render-thematic-break node))
      (:list-item (render-list-item node))
      (:ordered-item (render-list-item node))
      (t (list "")))))

(defun render-md (nodes)
  (let ((lines nil))
    (dolist (node nodes) (setf lines (nconc lines (render-md-node node))))
    lines))

(defun render-markdown (text)
  (unless text (return-from render-markdown ""))
  (let ((nodes (parse-blocks text)) (parts nil))
    (dolist (line (render-md nodes)) (push line parts))
    (with-output-to-string (s)
      (loop for part in (nreverse parts)
            for first = t then nil
            do (unless first (terpri s)) (princ part s)))))