cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-03-04 10:07:38 +01:00
Code Issues

- [fediverse] improved html rendering.

Browse Source
This commit is contained in:
cage 2024-11-03 13:49:52 +01:00
parent bee6b0470e
commit ce688f59b8
1 changed files with 89 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
src/html-utils.lisp
View File

@ -17,6 +17,14 @@
(in-package :html-utils) (in-package :html-utils)
(define-constant +tag-bold+ "b" :test #'string=)
(define-constant +tag-italic+ "i" :test #'string=)
(define-constant +tag-emphasis+ "em" :test #'string=)
(define-constant +tag-strong+ "strong" :test #'string=)
(define-constant +tag-link+ "a" :test #'string=) (define-constant +tag-link+ "a" :test #'string=)
(define-constant +tag-break+ "br" :test #'string=) (define-constant +tag-break+ "br" :test #'string=)
@ -116,6 +124,8 @@
(defparameter *ordered-list-item-number* 0) (defparameter *ordered-list-item-number* 0)
(defparameter *indentation-level* "")
(defun append-footnote-reference (text reference-number) (defun append-footnote-reference (text reference-number)
(strcat text (strcat text
(format nil (format nil
@ -134,6 +144,17 @@
(defun strip-footnote-reference (word) (defun strip-footnote-reference (word)
(cl-ppcre:regex-replace scanner word ""))) (cl-ppcre:regex-replace scanner word "")))
(defun block-tag-p (node)
(and (consp node)
(member node
(list +tag-break+
+tag-paragraph+
+tag-ordered-list+
+tag-unordered-list+
+tag-div+
+tag-blockquote+)
:test (lambda (a b) (tag= b a)))))
(defun html->text (html &key (defun html->text (html &key
(add-link-footnotes t) (body-footnotes-separator "") (add-link-footnotes t) (body-footnotes-separator "")
(quote-prefix "> ") (list-item-prefix "* ")) (quote-prefix "> ") (list-item-prefix "* "))
@ -153,12 +174,46 @@ Some convenience functions are provided to works with these structures.
(footnotes (misc:make-fresh-array 0 #\a 'character nil))) (footnotes (misc:make-fresh-array 0 #\a 'character nil)))
(with-output-to-string (body-stream body) (with-output-to-string (body-stream body)
(with-output-to-string (footnotes-stream footnotes) (with-output-to-string (footnotes-stream footnotes)
(format footnotes-stream "~2%") (labels ((print-line-break ()
(labels ((descend-children (node) (format body-stream "~%"))
(loop for child in (children node) do (print-line-break-maybe ()
(descend child))) (format body-stream "~&"))
(descend (node) (wrap-bold (node)
(format body-stream "*")
(descend-children node)
(format body-stream "*"))
(wrap-italic (node)
(format body-stream "/")
(descend-children node)
(format body-stream "/"))
(wrap-emphasis (node)
(format body-stream "_")
(descend-children node)
(format body-stream "_"))
(inc-indent (&optional (size 1))
(setf *indentation-level*
(strcat *indentation-level*
(make-string size :initial-element #\space))))
(dec-indent (&optional (size 1))
(when (>= (length *indentation-level*)
size)
(setf *indentation-level*
(subseq *indentation-level* size))))
(print-indent (stream)
;; (write-string (format nil "~a" (length *indentation-level*)) stream)
(write-string *indentation-level* stream))
(descend-children (node)
(loop
for count from 0
for child in (children node) do
(if (block-tag-p node)
(descend child t)
(descend child nil))))
(descend (node &optional (print-indent t))
(when node (when node
(when print-indent
(print-indent body-stream))
(cond (cond
((stringp node) ((stringp node)
(princ node body-stream)) (princ node body-stream))
@ -180,44 +235,61 @@ Some convenience functions are provided to works with these structures.
(when add-link-footnotes (when add-link-footnotes
(write-string (append-footnote-reference "" link-count) (write-string (append-footnote-reference "" link-count)
body-stream)))) body-stream))))
((or (tag= +tag-bold+ node)
(tag= +tag-strong+ node))
(wrap-bold node))
((tag= +tag-italic+ node)
(wrap-italic node))
((tag= +tag-emphasis+ node)
(wrap-emphasis node))
((tag= +tag-break+ node) ((tag= +tag-break+ node)
(let ((*block-tag* nil)) (let ((*block-tag* nil))
(format body-stream "~%") (print-line-break)
(descend-children node))) (descend-children node)))
((or (tag= +tag-paragraph+ node) ((or (tag= +tag-paragraph+ node)
(tag= +tag-div+ node)) (tag= +tag-div+ node))
(let ((*block-tag* t)) (let ((*block-tag* t))
(format body-stream "~%") (print-line-break)
(when *block-tag* (when *block-tag*
(loop for i from 0 below *quote-level* do (loop for i from 0 below *quote-level* do
(princ *prefix-text-line* body-stream))) (princ *prefix-text-line* body-stream)))
(descend-children node) (descend-children node)
(format body-stream "~%"))) (print-line-break)))
((tag= +tag-unordered-list+ node) ((tag= +tag-unordered-list+ node)
(let ((*ordered-list* nil) (let ((*ordered-list* nil)
(*unordered-list* t)) (*unordered-list* t))
(descend-children node))) (print-line-break-maybe)
(inc-indent)
(descend-children node)
(dec-indent)))
((tag= +tag-ordered-list+ node) ((tag= +tag-ordered-list+ node)
(let ((*ordered-list* t) (let ((*ordered-list* t)
(*unordered-list* nil) (*unordered-list* nil)
(*ordered-list-item-number* 0)) (*ordered-list-item-number* 0))
(descend-children node))) (print-line-break-maybe)
(inc-indent)
(descend-children node)
(dec-indent)))
((tag= +tag-list-item+ node) ((tag= +tag-list-item+ node)
(let ((*block-tag* nil)) (let ((*block-tag* nil))
(cond (cond
(*unordered-list* (*unordered-list*
(inc-indent (length list-item-prefix))
(format body-stream list-item-prefix) (format body-stream list-item-prefix)
(descend-children node) (descend-children node)
(format body-stream "~%")) (dec-indent (length list-item-prefix))
(print-line-break-maybe))
(*ordered-list* (*ordered-list*
(incf *ordered-list-item-number*) (incf *ordered-list-item-number*)
(inc-indent (length list-item-prefix))
(format body-stream "~a." *ordered-list-item-number*) (format body-stream "~a." *ordered-list-item-number*)
(descend-children node) (descend-children node)
(format body-stream "~%")) (dec-indent (length list-item-prefix))
(print-line-break))
(t (t
(format body-stream "unknown list type ") (format body-stream "unknown list type ")
(descend-children node) (descend-children node)
(format body-stream "~%"))))) (print-line-break)))))
((tag= +tag-blockquote+ node) ((tag= +tag-blockquote+ node)
(let ((*prefix-text-line* quote-prefix) (let ((*prefix-text-line* quote-prefix)
(*quote-level* (1+ *quote-level*)) (*quote-level* (1+ *quote-level*))
@ -227,7 +299,10 @@ Some convenience functions are provided to works with these structures.
(descend-children node)))))) (descend-children node))))))
(descend root) (descend root)
(if add-link-footnotes (if add-link-footnotes
(strcat body body-footnotes-separator footnotes) (strcat body
(format nil "~%")
body-footnotes-separator
footnotes)
body))))))) body)))))))
(defun extract-shotcodes (file) (defun extract-shotcodes (file)