printer.lisp

(in-package #:3bmd)

(defparameter *references* nil)
(defparameter *always-title* nil)
(defparameter *padding* 2)
(defmacro padded ((n s &optional (next 0)) &body body)
  (alexandria:once-only (n s next)
    `(progn
       (loop for ,n from ,n above *padding* do (format ,s "~%"))
       (setf *padding* ,n)
       (prog1
           (progn ,@body)
         (setf *padding* ,next)))))

(defun print-label-to-string (label)
  (with-output-to-string (s)
    (loop with spaces = (coerce '(#\space #\tab #\newline #\return #\linefeed)
                                'string)
       for was-space = nil then space
       for c across (with-output-to-string (s)
                      (loop for i in (alexandria:ensure-list label)
                         do (print-element i s)))
       for space = (find c spaces)
       when space
       do (unless was-space (write-char #\space s))
       else do (write-char c s))))

(defun lookup-reference (ref)
  #++(format t "lookup ref ~s -> ~s~%" (print-label-to-string ref)
          (gethash (print-label-to-string ref) *references*))
  (if *references*
      (gethash (print-label-to-string ref) *references*)))


(defun print-escaped (string stream)
  (loop for c across string
     when (eql c #\&) do (write-string "&" stream)
     else when (eql c #\<) do (write-string "&lt;" stream)
     else when (eql c #\>) do (write-string "&gt;" stream)
     else when (eql c #\") do (write-string "&quot;" stream)
     ;; todo: 'obfuscate' email addresses (when *obfuscate* ...)
     else do (write-char c stream)))

(defun escape-string (string)
  (when string
    (with-output-to-string (s)
      (print-escaped string s))))

(defun print-pre-escaped (string stream)
  (loop for c across string
     when (eql c #\<) do (write-string "&lt;" stream)
     else when (eql c #\>) do (write-string "&gt;" stream)
     else do (write-char c stream)))

(defun escape-pre-string (string)
  (when string
    (with-output-to-string (s)
      (print-pre-escaped string s))))

(defvar *allowed-id-chars* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890@$&'()*+.,;:?!=-_/"
  "A string of characters that are allowed to appear within an element ID string.")

(defun html-content-id (html)
  (with-output-to-string (out)
    (loop with state = :text
          for c across html
          do (case state
               (:text
                (cond ((eql c #\<)
                       (setf state :tag))
                      ((eql c #\ )
                       (write-char #\_ out))
                      ((find c *allowed-id-chars*)
                       (write-char (char-downcase c) out))))
               (:tag
                (when (eql c #\>)
                  (setf state :text)))))))

(defvar *generate-header-ids* NIL
  "Whether ID attributes should be generated for header elements.")

;; todo: minimize extra newlines...
(defmethod print-tagged-element ((tag (eql :heading)) stream rest)
  (let* ((contents (with-output-to-string (stream)
                     (dolist (a (getf rest :contents))
                       (print-element a stream))))
         (id (when *generate-header-ids* (html-content-id contents))))
    (padded (2 stream)
      (format stream "<h~d~@[ id=~s~]>" (getf rest :level) id)
      (write-string contents stream)
      (format stream "</h~d>" (getf rest :level)))))

(defmethod print-tagged-element ((tag (eql :paragraph)) stream rest)
  (padded (2 stream)
    (format stream "<p>")
    (dolist (a rest)
      (print-element a stream))
    (format stream "</p>")))

(defmethod print-tagged-element ((tag (eql :block-quote)) stream rest)
  (padded (2 stream)
    (format stream "<blockquote>~%")
    (dolist (a rest)
      (print-element a stream))
    (format stream "~&</blockquote>")))

(defmethod print-tagged-element ((tag (eql :plain)) stream rest)
  (padded (1 stream)
    (dolist (a rest)
      (print-element a stream))))


(defmethod print-tagged-element ((tag (eql :emph)) stream rest)
  (format stream "<em>")
  (dolist (a rest)
    (print-element a stream))
  (format stream "</em>"))

(defmethod print-tagged-element ((tag (eql :strong)) stream rest)
  (format stream "<strong>")
  (dolist (a rest)
    (print-element a stream))
  (format stream "</strong>"))

(defmethod print-tagged-element ((tag (eql :link)) stream rest)
  (format stream "<a href=\"~a\">~a</a>" (car rest) (car rest)))

(defun encode-email (text)
  (with-output-to-string (s)
    (loop for i upfrom 0
       for char across text
       do (cond
            ((= 0 (mod i 3)) (write-char char s))
            ;; fixme: make this portable to non-unicode/ascii lisps?
            ((= 1 (mod i 3)) (format s "&#x~x;" (char-code char)))
            (t (format s "&#~d;" (char-code char)))))))

(defmethod print-tagged-element ((tag (eql :mailto)) stream rest)
  (format stream "<a href=\"~a\">~a</a>" (encode-email (car rest))
          (encode-email (car rest))))

(defmethod print-tagged-element ((tag (eql :explicit-link)) stream rest)
  (format stream "<a href=\"~a\" ~@[title=\"~a\"~]>"
          (getf rest :source)
          (escape-string
           (or (getf rest :title) (if *always-title* "" nil))))
  (dolist (a (getf rest :label))
    (print-element a stream))
  (format stream "</a>"))

(defmethod print-tagged-element ((tag (eql :reference-link)) stream rest)
  (let* ((label (getf rest :label))
         (def (or (getf rest :definition) label))
         (ref (lookup-reference def)))
    (cond
      (ref
       (format stream "<a href=\"~a\" ~@[title=\"~a\"~]>" (first ref)
               (escape-string (or (second ref) (if *always-title* "" nil))))
       (dolist (a label)
         (print-element a stream))
       (format stream "</a>"))
      (t
       (warn "Unresolvable reference link ~S~%" rest)
       (format stream "[")
       (dolist (a label)
         (print-element a stream))
       (format stream "]")
       (when (getf rest :definition)
         (format stream "[")
         (dolist (a (getf rest :definition))
           (print-element a stream))
         (format stream "]"))
       (format stream "~@[~a~]" (getf rest :tail))))))

(defmethod print-tagged-element ((tag (eql :image)) stream rest)
  (setf rest (cdr (first rest)))
  (format stream "<img src=\"~a\" ~@[alt=\"~a\"~] ~@[title=\"~a\"~]/>"
          (getf rest :source)
          (with-output-to-string (s)
            (dolist (a (getf rest :label))
              (print-element a s)))
          (escape-string
           (or (getf rest :title) (if *always-title* "" nil)))))


(defmethod print-tagged-element ((tag (eql :counted-list)) stream rest)
  (padded (2 stream)
    (format stream "<ol>"))
  (dolist (a rest)
    (print-element a stream))
  (padded (1 stream)
    (format stream "~&</ol>")))

(defmethod print-tagged-element ((tag (eql :bullet-list)) stream rest)
  (padded (2 stream)
    (format stream "<ul>"))
  (dolist (a rest)
    (print-element a stream))
  (padded (1 stream)
    (format stream "</ul>")))

(defmethod print-tagged-element ((tag (eql :list-item)) stream rest)
  (padded (1 stream 2)
    (format stream "<li>"))
  (dolist (a rest)
    (print-element a stream))
  (format stream "</li>")
  (setf *padding* 0))

(defmethod print-tagged-element ((tag (eql :line-break)) stream rest)
  (format stream "<br/>~%"))

(defmethod print-tagged-element ((tag (eql :horizontal-rule)) stream rest)
  (padded (2 stream)
    (format stream "<hr/>")))


(defmethod print-tagged-element ((tag (eql :html)) stream rest)
  (padded (2 stream)
    (format stream "~{~a~}" rest)))

(defmethod print-tagged-element ((tag (eql :raw-html)) stream rest)
  (format stream "~{~a~}" rest))

(defmethod print-tagged-element ((tag (eql :entity)) stream rest)
  (format stream "~{~a~}" rest))

(defmethod print-tagged-element ((tag (eql :verbatim)) stream rest)
  (padded (2 stream)
    (format stream "<pre><code>")
    (dolist (a rest)
      (print-element a stream))
    (format stream "</code></pre>")))

;;; track whether we are in a code block, so we can avoid smart-quote
;;; junk if it was enabled in the parser
;;;
;;; possibly should just check the *smart-quotes* var from 3bmd-grammar
;;; and bind that to nil inside code blocks?
;;; (or make parser smart enough to not match inside code blocks)
(defparameter *in-code* nil)

(defmethod print-tagged-element ((tag (eql :code)) stream rest)
  (format stream "<code>")
  (let ((*in-code* t))
    (dolist (a rest)
      (print-element a stream)))
  (format stream "</code>"))

(defmethod print-tagged-element ((tag (eql :single-quoted)) stream rest)
  (if *in-code*
      (format stream "'")
      (format stream "&lsquo;"))
  (dolist (a rest)
    (print-element a stream))
  (if *in-code*
      (format stream "'")
      (format stream "&rsquo;")))

(defmethod print-tagged-element ((tag (eql :double-quoted)) stream rest)
  (if *in-code*
      (format stream "\"")
      (format stream "&ldquo;"))
  (dolist (a rest)
    (print-element a stream))
  (if *in-code*
      (format stream "\"")
      (format stream "&rdquo;")))

(defmacro define-smart-quote-entity (name replacement)
  `(defmethod print-tagged-element ((tag (eql ,name)) stream rest)
     (if *in-code*
         (format stream "~{~a~}" rest)
         (format stream ,replacement))))

(define-smart-quote-entity :em-dash "&mdash;")
(define-smart-quote-entity :en-dash "&ndash;")
(define-smart-quote-entity :left-right-single-arrow "&harr;")
(define-smart-quote-entity :left-single-arrow "&larr;")
(define-smart-quote-entity :right-single-arrow "&rarr;")
(define-smart-quote-entity :left-right-double-arrow "&hArr;")
(define-smart-quote-entity :left-double-arrow "&lArr;")
(define-smart-quote-entity :right-double-arrow "&rArr;")

(defmethod print-tagged-element ((tag (eql :ellipsis)) stream rest)
  (if *in-code*
      (format stream "~{~a~}" rest)
      (format stream "&hellip;")))

(defmethod print-tagged-element ((tag (eql :reference)) stream rest)
  )

(defmethod print-element ((elem null) stream)
  "")

(defmethod print-element ((elem (eql :apostrophe)) stream)
  (if *in-code*
      (format stream "'")
      (format stream "&apos;")))

(defmethod print-element ((elem string) stream)
  #++(format stream "~a" elem)
  (print-escaped elem stream))

(defmethod print-element ((elem cons) stream)
  (if (symbolp (car elem))
      (print-tagged-element (car elem) stream (cdr elem))
      (error "unknown cons? ~s" elem)))



(defun extract-refs (doc)
  (alexandria:alist-hash-table
   (loop for i in doc
      when (and (consp i) (eq (car i) :reference))
      collect (list (print-label-to-string (getf (cdr i) :label))
                    (getf (cdr i) :source)
                    (getf (cdr i) :title)))
   :test #'equalp))

(defun expand-tabs (doc &key add-newlines)
  (with-output-to-string (s)
    (let ((pos 0))
      (flet ((out (c)
               (incf pos)
               (write-char c s)))
       (loop
          for i across doc
          do (case i
               ((#\newline)
                (setf pos 0)
                (write-char i s))
               ((#\tab)
                (loop repeat (- 4 (mod pos 4)) do (out #\space)))
               (t (out i))))))
    (when add-newlines
      (format s "~%~%"))))


(defmethod print-doc-to-stream-using-format (doc stream (format (eql :html)))
  (let ((*references* (extract-refs doc))
        ;; Protect the global value.
        (*padding* *padding*))
    (loop for i in doc
          do (print-element i stream))
    (format stream "~&")))

(defun print-doc-to-stream (doc stream &key (format :html))
  (print-doc-to-stream-using-format doc stream format))

(defun parse-and-print-to-stream (file stream &key (format :html))
  (let* ((input (expand-tabs (alexandria:read-file-into-string file)
                             :add-newlines t))
         (doc (3bmd-grammar::parse-doc input)))
    (print-doc-to-stream doc stream :format format)))

(defun parse-string-and-print-to-stream (string stream &key (format :html))
  (let* ((input (expand-tabs string :add-newlines t)))
    (print-doc-to-stream (3bmd-grammar::parse-doc input) stream
                         :format format)))