Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 57ed384437
Fetching contributors…

Cannot retrieve contributors at this time

file 96 lines (84 sloc) 4.507 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
(in-package #:cliki2)
(in-readtable cliki2)

(sanitize:define-sanitize-mode +links-only+
    :elements ("a")
    :attributes (("a" . ("href" "class")))
    :protocols (("a" . (("href" . (:ftp :http :https :mailto :relative))))))

(sanitize:define-sanitize-mode +cliki-tags+
    :elements ("a" "blockquote" "q" "dd" "dl" "dt" "h1" "h2" "h3" "h4" "h5"
               "h6" "hgroup" "pre" "code" "kbd" "samp" "cite" "var" "time"
               "figure" "figcaption" "img" "table" "caption" "tbody" "td"
               "tfoot" "th" "thead" "tr" "col" "colgroup" "ul" "ol" "li" "b"
               "em" "i" "small" "strike" "strong" "dfn" "s" "sub" "sup" "u"
               "abbr" "ruby" "rp" "rt" "bdo" "mark")
    :attributes ((:all . ("dir" "lang" "title" "class"))
                 ("a" . ("href"))
                 ("abbr" . ("title"))
                 ("bdo" . ("dir"))
                 ("blockquote" . ("cite"))
                 ("col" . ("span" "width" "align" "valign"))
                 ("colgroup" . ("span" "width" "align" "valign"))
                 ("img" . ("align" "alt" "height" "src" "width"))
                 ("ol" . ("start" "reversed" "type"))
                 ("ul" . ("type"))
                 ("code" . ("lang"))
                 ("q" . ("cite"))
                 ("table" . ("summary" "width"))
                 ("td" . ("abbr" "axis" "colspan" "rowspan" "width"))
                 ("th" . ("abbr" "axis" "colspan" "rowspan" "scope" "width")))

    :protocols (("a" . (("href" . (:ftp :http :https :mailto :relative))))
                ("blockquote" . (("cite" . (:http :https :relative))))
                ("img" . (("src" . (:http :https :relative))))
                ("q" . (("cite" . (:http :https :relative))))))

(defun generate-html-from-markup (markup)
  #H[<div id="article">]
  (princ (parse-cliki-markup (sanitize:clean markup +cliki-tags+))
         *html-stream*)
  #H[</div>])

(defun parse-cliki-markup (markup)
  (loop for prefix in '("_" "_H" "\\*" "\\/" "_P")
     for formatter in '(pprint-article-link format-hyperspec-link pprint-category-link format-category-list format-package-link)
     do (setf markup (process-cliki-rule markup prefix formatter)))
  (ppcre:regex-replace-all "\\n\\n" (colorize-code markup) "<p>"))

(defun process-cliki-rule (markup prefix formatter)
  (ppcre:regex-replace-all #?/${prefix}\((.*?)\)/
                           markup
                           (lambda (match r1)
                             (declare (ignore match))
                             (with-output-to-string (*html-stream*)
                              (funcall formatter r1)))
                           :simple-calls t))

(defmethod pprint-article-summary-li ((article article) separator)
  #H[<li>] (pprint-article-link (title article)) #H[ ${separator}
  ${(sanitize:clean (with-output-to-string (*html-stream*)
                      (generate-html-from-markup (article-description article)))
                    +links-only+)}
  </li>])

(defun format-category-list (category) ;; /(
  #H[<ul>] (dolist (article (sort (copy-list
                                   (articles-with-category
                                    (category-keyword category)))
                                  #'string< :key 'canonical-title))
             (pprint-article-summary-li article "-"))
  #H[</ul>])

(defun format-hyperspec-link (symbol) ;; _H(
  #H[<a href="${(clhs-lookup:spec-lookup symbol)}" class="hyperspec">${symbol}</a>])

(defun format-package-link (link) ;; _P(
  #H[<a href="${link}" class="download">Download ASDF package from ${link}</a>])

;;;; do something with code-block

(let ((supported-langs (sort (mapcar (lambda (x)
                                       (symbol-name (car x)))
                                     colorize::*coloring-types*)
                             #'> :key #'length)))
  (defun colorize-code (markup)
    (ppcre:regex-replace-all
     "<code(.*?)?>(.*?)</code>" markup
     (lambda (match maybe-lang code)
       (declare (ignore match))
       (let ((lang (loop for lang in supported-langs
                         when (search lang maybe-lang :test #'char-equal)
                         return (find-symbol lang :keyword))))
         (if lang
             #?[<div class="code">${(colorize::html-colorization lang code)}</div>]
             #?[<code>${code}</code>])))
     :simple-calls t)))
Something went wrong with that request. Please try again.