(in-package #:chains)

(defconstant +special-characters+
  '(#\\ #\% #\@ #\$ #\{ #\} #\[ #\] #\Newline)
  "")

(defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space)
  "")

;; TODO: (read-char stream nil)
(defun read-if (predicate stream)
  "Read characters from STREAM into a string as long as PREDICATE is true"
  (let ((string (with-output-to-string (value)
                  (loop :for c = (read-char stream nil)
                        :while (and c (funcall predicate c))
                        :do (write-char c value)
                        :finally
                           (when c (unread-char c stream))))))
    (if (emptyp string) nil string)))

(defun read-if-not (predicate stream)
  "Read characters from STREAM into a string as long as PREDICATE is false"
  (read-if (complement predicate) stream))

(defun read-text (stream start-of-line)
  "Read text from STREAM"
  (let* ((text (read-if-not #'special-char-p stream))
         (peek (peek-char nil stream nil)))
    (when text (setf start-of-line nil))
    (cond ((and (null text) (null peek))
           nil)
          ((and (not start-of-line) (newlinep peek))
           (read-char stream nil)
           (let ((rest (read-text stream t)))
             (when (eq rest 'empty-line)
               (setf rest nil)
               (unread-char #\Newline stream))
             (list* text (string #\Newline) rest)))
          ((newlinep peek)
           (read-char stream nil)
           'empty-line)
          (t
           (ensure-list text)))))

(defun atom-char-p (char)
  "Is CHAR allowed as an atom char"
  (or (alphanumericp char) (member char '(#\- #\*))))

(defun next-token (stream start-of-line &aux c)
  "Read the next token inside STREAM"
  (case (setf c (read-char stream nil))
    ('nil nil)
    (#\\
     (concat-text (make-text (string (read-char stream nil)))
                  (make-text (read-if-not #'special-char-p stream))))
    (#\%
     (peek-char #\Newline stream)
     (read-char stream nil)
     ;;(next-token stream nil)
     'separator)
    ((#\@ #\$)
     (let* ((text (read-if #'atom-char-p stream))
            (value (read-from-string text))
            (type (cond ((symbolp value)
                         (setf value (intern (symbol-name value) *interpreter-package*))
                         :symbol)
                        ((integerp value) :integer)
                        (t (error "Unknown type of object @~A~%" text)))))
       ;; (unless (or (symbolp value) (integerp value))
       ;;   (error "Unknown type of object @~A~%" text))
       (make-object type value)))
    (#\{ 'link-start)
    (#\} 'link-end)
    (#\[ 'raw-link-start)
    (#\] 'raw-link-end)
    (t
     (unread-char c stream)
     (let ((text (read-text stream start-of-line)))
       (cond ((null text) nil)
             ((symbolp text) text)
             (t (make-text (apply #'concatenate 'string text))))))))

(defun build-tree (tokens)
  "Groups a list of tokens into a tree. Returns a subtree and a list of unused
tokens."
  (flet ((build-chain (tokens)
           (loop :with tokens = tokens
                 :for (link rest) = (multiple-value-list (build-tree tokens))
                 :collect link :into links
                 :while (member (first rest) '(raw-link-start link-start))
                 :do (setf tokens (rest rest))
                 :finally
                    (setf tokens rest)
                    (return (values links tokens)))))
    (destructuring-bind (&optional head &rest tail) tokens
      (cond ((null head)
             (values nil '()))
            ((or (eq head 'link-end) (eq head 'raw-link-end))
             (values '() (rest tokens)))
            ((eq head 'separator)
             (multiple-value-bind (tree rest) (build-tree tail)
               (values tree rest)))
            ;; @a{...} <-> {@a}{...}
            ((and (object-symbolp head)
                  (eq (first tail) 'link-start))
             (multiple-value-bind (links rest) (build-chain (rest tail))
               (multiple-value-bind (tree rest) (build-tree rest)
                 (values (cons (make-chain (cons (list head) links)) tree) rest))))
            ((eq head 'link-start)
             (multiple-value-bind (links rest) (build-chain tail)
               (multiple-value-bind (tree rest) (build-tree rest)
                 (values (cons (make-chain links) tree) rest))))
            (t
             (multiple-value-bind (tree rest) (build-tree tail)
               (values (cons head tree) rest)))))))

(defun read-raw-link (stream)
  "Read argument of a raw function"
  (flet ((squarep (x) (member x '(#\]))))
    ;; Text omits closing ], may therefore be nil, for example when reading ]]
    (loop :for text = (read-if-not #'squarep stream)
          :for c = (peek-char nil stream nil)
          :when text :collect text :into text-list
          :while (and c text (eql (last-elt text) #\\))
          :collect (string (read-char stream nil)) :into text-list
          :finally
             ;; Keep ] inside stream
             (return (list (make-text (apply #'concat text-list)))))))

(defun start-of-line-p (last-token)
  ;; Keep track if new line starts a paragraph
  (or (eq last-token 'empty-line)
      (and (textp last-token)
           (newlinep (last-elt (content last-token))))))

(defun read-tree (stream)
  "Build a syntax tree from the contents of STREAM"
  (loop :with start-of-line = t
        :for token = (next-token stream start-of-line)
        :while token
        :if (eq token 'raw-link-start)
          :append (cons 'raw-link-start (read-raw-link stream)) :into tokens
          :and :do
            (setf start-of-line nil)
        :else
          :collect token :into tokens :and :do
            (setf start-of-line (start-of-line-p token))
        :finally ;; (build-tree)
           (return tokens)))