(in-package :tml)

(lisp:clines "#include \"text.c\"")
(lisp:defentry %find-break-point (lisp:object lisp:int) (lisp:int "find_break_point"))
(lisp:defentry %format-text (lisp:object lisp:object lisp:int lisp:int) (lisp:object "format_text"))
(lisp:defentry %word-wrap (lisp:object lisp:object lisp:int) (lisp:void "word_wrap"))

(defun find-break-point (string max)
  (let* ((value (%find-break-point string max))
	 (flag (ldb (byte 1 0) value))
	 (n (ldb (byte 15 1) value)))
    (if (= flag 0)
	(values nil n)
	(values n 0))))

(defun render-text
    (string
     &key
     (stream *html-output*)
     preformattedp
     linkify-urls-p
     add-paragraphs-p
     in-para-p
     (ignore-leading-whitespace-p t)
     (ignore-trailing-whitespace-p t)
     (length (length string)))
  (when (plusp length)
    (%format-text string
		  stream
		  (logior
		   (if preformattedp 1 0)
		   (if add-paragraphs-p 2 0)
		   (if linkify-urls-p 4 0)
		   (if in-para-p 8 0)
		   (if ignore-leading-whitespace-p 16 0)
		   (if ignore-trailing-whitespace-p 32 0))
		  length)))

(defun word-wrap (string &key (stream *html-output*) (max-width 80))
  (when (plusp (length string))
    (%word-wrap string stream max-width)))

(defconstant +safe-elements+
  '(:a
    :abbr
    :acronym
    (:address :block)
    :b
    :big
    (:blockquote :block)
    (:br :empty)
    (:break :empty)
    (:caption :block)
    (:center :block)
    :cite
    :code
    (:col :empty)
    (:colgroup :block :no-pcdata)
    :dfn
    (:div :block)
    (:dd :block)
    (:dl :block :no-pcdata)
    (:dt :block)
    :em
    (:embed :block :empty)
    :font
    (:h1 :block)
    (:h2 :block)
    (:h3 :block)
    (:h4 :block)
    (:h5 :block)
    (:h6 :block)
    (:hr :empty)
    :i
    (:iframe :block)
    (:img :empty)
    :kbd
    (:li :block)
    (:more :empty :block)
    :nobr
    (:object :block :no-pcdata)
    (:ol :block :no-pcdata)
    (:p :block)
    (:param :empty)
    (:pre :block :preformatted)
    :q
    :s
    :samp
    :small
    :span
    :strike
    :strong
    :sub
    :sup
    (:table :block :no-pcdata)
    (:tbody :block :no-pcdata)
    (:td :block)
    (:tfoot :block :no-pcdata)
    (:th :block)
    (:thead :block :no-pcdata)
    (:tr :block :no-pcdata)
    :tt
    :u
    (:ul :block :no-pcdata)
    :var
    (:wbr :empty)))

(defconstant +restricted-elements+
  '(:body
    :button
    :form
    (:head :no-pcdata)
    :html
    (:input :empty)
    :label
    (:link :empty)
    (:meta :empty)
    :option
    :script
    (:select :no-pcdata)
    :style
    :textarea
    :title))

(defun register-elements (list &rest default-flags)
  (dolist (element list)
    (multiple-value-bind (name flags)
	(if (consp element)
	    (values (first element) (rest element))
	    (values element nil))
      (setf (get name 'html::element)
	    (list* nil (append flags default-flags))))))

(register-elements +safe-elements+ :safe)
(register-elements +restricted-elements+)

(defun start-auto-close-p (name auto-name)
  (case auto-name
    (:p (element-has-flag name :block))
    (:li (eq name :li))
    (:dt (case name ((:dt :dd) t)))
    (:tr (eq name :tr))
    (:td (case name ((:tr :td) t)))
    (t nil)))

(defun end-auto-close-p (name auto-name)
  (case auto-name
    (:p (and (not (eq name :p)) (element-has-flag name :block)))
    (:li (case name ((:ol :ul) t)))
    ((:dt :dd) (eq name :dl))
    (:tr (eq name :table))
    (:td (case name ((:table :tr) t)))
    (t nil)))

(defun whitespace-element-p (form)
  (or (whitespacep form)
      (and (consp form)
	   (eq (element-name form) :br))))

(defun parse-tml (stream &key (safe t))
  (when (stringp stream)
    (setf stream (make-string-input-stream stream)))
  (let (stack
	tag
	short-form-p
	content
	(buf (make-string-output-stream)))
    (macrolet ((collect-chars (&key while until (writep t) consumep)
		 (when (characterp until)
		   (setf until `(char= char ,until)))
		 `(loop for char = (peek-char nil stream nil nil)
		        while ,(if while `(and char ,while) 'char)
                        ,@(and until `(until ,until))
		        do ,(if writep `(collect-char (read-char stream)) `(read-char stream))
		        finally (progn
				  ,(when consumep
				     `(when char
				        (read-char stream)))
				  (return char))))
	       (get-collected-chars (&rest args)
		 (with-unique-names (char)
		   `(let ((,char (collect-chars ,@args)))
        	      (values (maybe-get-output-stream-string buf)
		              ,char))))
	       (maybe-read-char (test &optional skip-whitespace-p)
		 (when (characterp test)
		   (setf test `(char= char ,test)))
		 `(whereas ((char (peek-char ,skip-whitespace-p stream nil nil)))
		    (when ,test
		      (read-char stream))))
	       (auto-close (pred)
		 `(loop while (and tag (,pred name (tag-name tag)))
		        do (close-element))))
      (labels ((word-char-p (char)
		 (or (alphanumericp char) (char= char #\-)))
	       (read-symbol (&optional (package :keyword))
		 (multiple-value-bind (word char)
		     (get-collected-chars :while (word-char-p char))
		   (if (eq char #\:)
		       (let ((package
			      (cond
				((string-equal word (package-name site:+package+))
				 site:+package+)
				((string-equal word "html")
				 :keyword))))
			 (multiple-value-bind (word char)
			     (get-collected-chars :while (word-char-p char))
			   (values
			    (and word package (intern (string-upcase word) package))
			    package
			    word
			    char)))
		       (values
			(and word (intern (string-upcase word) package))
			package
			word
			char))))
	       (collect-char (char)
		 (unless (char= char #\Return)
		   (write-char char buf)))
	       (save-pcdata (&key trim-right-p)
		 (when trim-right-p
		   (let* ((string (si:output-stream-string buf))
			  (length (length string)))
		     (when (and (plusp length) (char= (char string (decf length)) #\Newline))
		       (setf (fill-pointer string) length))))
		 (whereas ((string (maybe-get-output-stream-string buf)))
		   (push string content)))
	       (open-element (name)
		 (push (cons (cons tag short-form-p) content) stack)
		 (setf tag name content nil))
	       (close-element ()
		 (let* ((element (cons tag (nreverse content)))
			(prev (pop stack)))
		   (setf tag (caar prev) short-form-p (cdar prev) content (cdr prev))
		   (push element content)
		   element))
	       (read-attribute-name (package)
		 (let* ((lisp-form-p (maybe-read-char #\: t))
			(char (peek-char t stream nil nil)))
		   (when (and char (alpha-char-p char))
		     (values (read-symbol package) lisp-form-p))))
	       (read-attribute-value ()
		 (case (peek-char t stream nil nil)
		   ((#\" #\')
		    (let ((quote-char (read-char stream)))
		      (get-collected-chars :until (char= char quote-char) :consumep t)))
		   (t (get-collected-chars :until (or (case char ((#\< #\> #\|) t)) (whitespacep char))))))
	       (read-attributes (package)
		 (loop with name and lisp-form-p
		       do (setf (values name lisp-form-p) (read-attribute-name package))
		       while name
		       collect name
		       collect
		       (or (cond
			     (lisp-form-p
			      (read stream nil nil))
			     ((maybe-read-char #\= t)
			      (read-attribute-value)))
			   ""))))
	(peek-char t stream nil nil)
	(loop with end-tag-p = nil
	      for char = (read-char stream nil nil)
	      while char
	      do (case char
		   (#\<
		    (cond
		      ((maybe-read-char #\!)
		       (collect-chars :until #\> :writep nil :consumep t))
		      ((and (maybe-read-char #\|) (peek-char t stream nil nil))
		       (let ((terminating-char (read-char stream)))
			 (collect-chars :until (char= char terminating-char) :consumep t)
			 (maybe-read-char #\|)
			 (maybe-read-char #\>)))
		      ((progn
			 (setf end-tag-p (maybe-read-char #\/))
			 (and (setf char (peek-char nil stream nil nil))
			      (alpha-char-p char)))
		       (save-pcdata :trim-right-p end-tag-p)
		       (multiple-value-bind (name package string) (read-symbol)
			 (cond
			   ;; If there is an unrecognized namespace then simply skip the whole tag as if it
			   ;; wasn't there. This is largely to cope with the "<o:p>" bilge spewed by MS Word.
			   ((not name) (collect-chars :until #\> :writep nil :consumep t))
			   ((or (not safe) (element-has-flag name :safe))
			    (if end-tag-p
				(progn
				  (when (and tag (not (element-has-flag name :empty)))
				    (auto-close end-auto-close-p)
				    (close-element))
				  (maybe-read-char #\> t))
				(progn
				  (auto-close start-auto-close-p)
				  (open-element name)
				  (whereas ((attributes (read-attributes package)))
				    (setf tag (cons tag attributes)))
				  (setf short-form-p (case (peek-char t stream nil nil) ((#\| #\<) t)))
				  (let ((terminating-char (maybe-read-char (case char ((#\| #\>) t)))))
				    (when terminating-char
				      (maybe-read-char #\Return)
				      (maybe-read-char #\Newline))
				    (when (or (and (eql terminating-char #\>) (element-has-flag name :empty))
					      (and (not terminating-char) (maybe-read-char #\/) (maybe-read-char #\> t)))
				      (close-element))))))
			   (t
			    (write-string "&lt;" buf)
			    (when end-tag-p
			      (write-char #\/ buf))
			    (write-string string buf)))))
		      (t
		       (write-string "&lt;" buf)
		       (when end-tag-p
			 (write-char #\/ buf)))))
		   (#\>
		    (if short-form-p
			(progn
			  (save-pcdata)
			  (close-element))
			(write-string "&gt;" buf)))
		   (t
		    (unless (and tag (element-has-flag (tag-name tag) :no-pcdata))
		      (collect-char char)))))
	(save-pcdata)
	(loop while tag
	      do (close-element))
	(loop while (whitespace-element-p (first content))
	      do (pop content)
	      finally (return (nreverse content)))))))

(defvar *add-html-p* t)
(defvar *trim-whitespace-p* t)
(defvar *preformattedp* nil)
(defvar *allow-elements-p* t)
(defvar *allow-block-level-p* t)
(defvar *allow-links-p* t)
(defvar *excerptp* t)
(defvar *anonymous-first-block-p* nil)

(defun soaks-whitespace-p (object)
  (or (and *trim-whitespace-p* (not object))
      (and (consp object)
	   (whereas ((name (element-name object)))
	     (or (eq name :br)
		 (element-has-flag name :block))))))

(defun render-content (list excerptp anonymous-first-block-p)
  (loop with morep = nil
	with written-block-p = nil
	with in-para-p = nil
	for prev = nil then object
	for (object next . rest) on list
	do (etypecase object
	     (string
              (let ((ignore-leading-whitespace-p (soaks-whitespace-p prev))
                    (ignore-trailing-whitespace-p (soaks-whitespace-p next)))
                (unless (and ignore-leading-whitespace-p
                             ignore-trailing-whitespace-p
		             (whitespacep object))
     	          (when (and *add-html-p*
			     *allow-block-level-p*
			     (not in-para-p)
			     (or written-block-p (not anonymous-first-block-p)))
		    (write-string "<p>" *html-output*)
		    (setf in-para-p t written-block-p t))
	          (setf in-para-p
		        (render-text
		         object
		         :preformattedp *preformattedp*
		         :linkify-urls-p (and *add-html-p* *allow-links-p*)
			 :add-paragraphs-p (and *add-html-p* *allow-block-level-p*)
		         :in-para-p in-para-p
		         :ignore-leading-whitespace-p ignore-leading-whitespace-p
		         :ignore-trailing-whitespace-p ignore-trailing-whitespace-p)
			written-block-p
			in-para-p))))
	     (cons
              (if (eq (element-name object) :more)
                  (when excerptp (setf morep t))
  	          (multiple-value-bind (name attributes content) (parse-element object)
		    (when (and *allow-elements-p*
			       (or *allow-block-level-p* (not (element-has-flag name :block)))
			       (or *allow-links-p* (not (eq name :a))))
		      (if (element-has-flag name :block)
			  (progn
			    (setf written-block-p t)
			    (when in-para-p
			      (write-string "</p>" *html-output*)
			      (setf in-para-p nil)))
			  (when (and *add-html-p*
				     *allow-block-level-p*
				     (not in-para-p)
				     (or written-block-p (not anonymous-first-block-p)))
			    (write-string "<p>" *html-output*)
			    (setf in-para-p t written-block-p t)))
		      (format *html-output* "<~(~a~)" name)
		      (loop for (att-name att-value) on attributes by #'cddr do
			    (format *html-output* " ~(~a~)=\"" att-name)
			    (render-text att-value)
			    (write-char #\" *html-output*))
		      (write-char #\> *html-output*))
		    (unless (element-has-flag name :empty)
		      (let* ((*add-html-p* nil)
			     (*preformattedp* (or *preformattedp* (element-has-flag name :preformatted)))
			     (*trim-whitespace-p* (and (not *preformattedp*) (element-has-flag name :block))))
		        (setf morep (render-content content)))
		      (when (and *allow-elements-p*
				 (or *allow-block-level-p* (not (element-has-flag name :block)))
				 (or *allow-links-p* (not (eq name :a))))
			(format *html-output* "</~(~a~)>" name)))))
	      (when morep
		(loop-finish))))
	finally (progn
		  (when in-para-p
		    (write-string "</p>" *html-output*))
		  (return morep))))

(defun render-markup (string &key (excerptp *excerptp*) (anonymous-first-block-p *anonymous-first-block-p*))
  (when (plusp (length string))
    (if (find #\< string)
	(let ((*add-html-p* *allow-elements-p*))
	  (render-content (parse-tml string) excerptp anonymous-first-block-p))
	(prog1 nil
	  (if anonymous-first-block-p
	      (when (render-text string :linkify-urls-p t :add-paragraphs-p t)
		(write-string "</p>" *html-output*))
	      (html (:p (render-text string :linkify-urls-p t :add-paragraphs-p t :in-para-p t))))))))

(defun render-inline-markup (string)
  (when (plusp (length string))
    (if (find #\< string)
	(let ((*add-html-p* *allow-elements-p*)
	      (*allow-block-level-p* nil))
	  (render-markup string))
	(render-text string))))

(defun render-teaser-text (string &key (max 250) &aux elementp need-space-p)
  (when (plusp (length string))
    (labels ((render-content (list)
	       (loop with prev = nil
		     for prev = nil then object
		     for (object next . rest) on list
		     do (etypecase object
			  (string
			   (let ((ignore-leading-whitespace-p (soaks-whitespace-p prev))
				 (ignore-trailing-whitespace-p (soaks-whitespace-p next)))
			     (unless (and ignore-leading-whitespace-p
					  ignore-trailing-whitespace-p
					  (whitespacep object))
			       (let (point)
				 (setf elementp nil
				       (values point max) (find-break-point object max))
				 (when need-space-p
				   (write-char #\space *html-output*)
				   (setf need-space-p nil))
				 (render-text
				  object
				  :length point
				  :ignore-leading-whitespace-p ignore-leading-whitespace-p
				  :ignore-trailing-whitespace-p ignore-trailing-whitespace-p))
			       (when (zerop max)
				 (return-from render-content t)))))
			  (cons
			   (let* ((name (element-name object))
				  (block-level-p (block-level-p name)))
			     (setf need-space-p (and block-level-p prev)
				   elementp t)
			     (when (or (eq name :more)
				       (unless (always-empty-p name)
					 (let ((*trim-whitespace-p* block-level-p))
					   (prog1 (render-content (rest object))
					     (setf need-space-p block-level-p)))))
			       (return-from render-content t))))))))
      (when (if (find #\< string)
		(or (render-content (parse-tml string)) elementp)
		(let (point)
		  (setf (values point max) (find-break-point string max))
		  (render-text string :length point)
		  (zerop max)))
	(html "...")
	t))))