(in-package :clim-doc)

;;;; Very Basic TeX Input

;; ### due the method used to implement the various macros, we loose
;;     the ability to show the line number / character offset when we
;;     encounter a parsing error -- fix that.



(defvar *catcode-table*
  (make-hash-table :test #'eql))

(defun catcode-define (char code)
  (cond ((eql code :other)
         (remhash char *catcode-table*))
        (t
         (setf (gethash char *catcode-table*) code))))

(defun catcode (char)
  (gethash char *catcode-table* :other))

(progn
  ;; ### are these categories right, how to query them from a real LaTeX?
  ;;
  ;; Fill default catcode table
  (catcode-define #\\ :escape)
  (catcode-define #\{ :group-begin)
  (catcode-define #\} :group-end)
  (catcode-define #\$ :math)
  ;; alignment tab skipped
  (catcode-define #\newline :end-of-line)
  (catcode-define #\# :param)
  (catcode-define #\^ :superscript)
  (catcode-define #\_ :subscript)
  (catcode-define #\space :space)
  (catcode-define #\tab :space)
  (catcode-define #\* :letter)
  (loop for c across "abcdefghijklmnopqrstuvwxyz"
        do (catcode-define c :letter))
  (loop for c across "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        do (catcode-define c :letter))
  (catcode-define #\~ :active)
  (catcode-define #\& :active)
  (catcode-define #\% :comment)
  )  

;;;; Our Input

(defstruct input-stream
  ;; We have a token lookahead as well as a character lookahead.
  token-lookahead
  char-lookahead
  ;; .. and some CL stream
  stream)

(defun make-tex-input (stream)
  (make-input-stream :stream stream))

(defun read-char* (input-stream &optional (eof-error-p t) eof-value)
  ;; Reads a character from a tex-stream
  (or (pop (input-stream-char-lookahead input-stream))
      (read-char (input-stream-stream input-stream) eof-error-p eof-value)))

(defun peek-char* (input-stream &optional (eof-error-p t) eof-value)
  ;; Peeks a character from a tex-stream
  (or (car (input-stream-char-lookahead input-stream))
      (peek-char nil (input-stream-stream input-stream) eof-error-p eof-value)))

(defun unread-char* (c input-stream)
  ;; Unreads a character to a tex-stream
  (push c (input-stream-char-lookahead input-stream)))

;;;; Tokens

(defun make-token (category &optional value)
  (unless (member category
                  '(:eof :cs :group-begin :group-end :math :par :param :superscript :subscript
                         :space :char))
    (error "Bad token category: ~S." category))
  (cond ((eq :char category)
         value)
        ((eq :param category)
         (unless (and (consp value) (<= 2 (length value) 3))
           (error "Malformed :PARAM token: ~S." value))
         (list category value))
        (t
         (list category value))))

(defun token-equal (x y)
  (and (eq (token-category x) (token-category y))
       (case (token-category x)
         (:char (eql (token-value x) (token-value y)))
         (:cs   (string= (token-value x) (token-value y)))
         (otherwise t))))

(defun token-category (token)
  (if (characterp token)
    :char
    (first token)))

(defun token-value (token)
  (if (characterp token)
    token
    (second token)))

(defun skip-spaces (input)
  (do ((c (peek-char* input nil :eof) (peek-char* input nil :eof)))
      ((or (eq :eof c)
           (not (eql :space (catcode c)))))
    (read-char* input)))

(defun param-kind (x) (first x))
(defun param-n (x) (second x))
(defun param-default (x) (third x))

(defun read-token (input)
  "Reads a token from a tex-stream."
  (or (pop (input-stream-token-lookahead input))
      (let ((c (read-char* input nil :eof)))
        (cond ((eql c :eof)
               (make-token :eof))
              (t
               (ecase (catcode c)
                 (:escape
                  (let ((c (read-char* input)))
                    (if (eql :letter (catcode c))
                      (make-token :cs
                                  (prog1 
                                      (with-output-to-string (bag)
                                        (write-char c bag)
                                        (do ((c (peek-char* input) (peek-char* input)))
                                            ((not (eql :letter (catcode c))))
                                          (read-char* input)
                                          (write-char c bag)))
                                    (skip-spaces input)))
                      (make-token :cs (string c)))))
                 (:active
                  (make-token :cs (concatenate 'string " char " (string c))))
                 (:group-begin
                  (make-token :group-begin))
                 (:group-end
                  (make-token :group-end))
                 (:math
                  (make-token :math))
                 (:end-of-line
                  ;; look out for a blank line
                  (let ((consumed nil))
                    (loop
                      (let ((c (read-char* input nil :eof)))
                        (when (eq :eof c)
                          (return (make-token :par)))
                        (push c consumed)
                        (case (catcode c)
                          (:space)
                          (:end-of-line
                           (return (make-token :par)))
                          (otherwise
                           ;; Put back, what we read
                           (dolist (k consumed)
                             (unread-char* k input))
                           ;; return a space
                           (return (make-token :space))))))))
                 (:param
                  (let ((d (read-char* input)))
                    (cond ((char= #\[ d)
                           ;; This is an extension to TeX, and copes with LaTeX's idea
                           ;; of optional macro parameters. Write #[<n><default>] to
                           ;; introduce the n'th parameter as one being optional and
                           ;; delimited by #\[ and #\] and having the default value
                           ;; <default>.
                           (let* ((d (read-char* input))
                                  (n (or (digit-char-p d)
                                         (perror input "Non digit char ~S after ~S #\[." d c)))
                                  (default
                                    (loop
                                      for tok = (read-token input)
                                      until (token-equal tok (make-token :char #\]))
                                      collect tok)))
                             (make-token :param
                                         (list :optional n default))) )
                          ((digit-char-p d)
                           ;; Ordinary TeX parameter
                           (make-token :param (list :required (digit-char-p d))))
                          (t
                           (perror input "Non digit char ~S after ~S." d c)))))
                 (:superscript
                  (make-token :superscript))
                 (:subscript
                  (make-token :subscript))
                 (:space
                  (do ((c (peek-char* input nil :eof) (peek-char* input nil :eof)))
                      ((or (eq :eof c)
                           (not (eql :space (catcode c))))
                       ;; finally
                       (cond ((eql :end-of-line (catcode c))
                              ;; Spaces before end of line are ignored
                              (read-token input))
                             (t
                              (make-token :space))))
                    (read-char* input)))
                 ((:letter :other)
                  ;; minimal ligature support
                  (cond ((and (eql c #\`) (eql (peek-char* input nil :eof) #\`)) (read-char* input) (setf c #\"))
                        ((and (eql c #\') (eql (peek-char* input nil :eof) #\')) (read-char* input) (setf c #\")))
                  ;;
                  (make-token :char c))
                 ;;
                 (:comment
                  (let ((comment
                         (with-output-to-string (bag)
                           (do ((c (read-char* input) (read-char* input)))
                               ((eql #\newline c))
                             (write-char c bag)))))
                    (when (string= comment "-CONV")
                      (warn "Detected %-CONV")
                      (let ((matchee "%+CONV")
                            (s (make-array 0 :element-type (array-element-type "")
                                           :fill-pointer 0
                                           :adjustable t)))
                        (do ((c (read-char* input) (read-char* input)))
                            ((and (> (length s) (length matchee))
                                  (string= s matchee :start1 (- (length s) (length matchee)))))
                          (vector-push-extend c s)))))
                  (read-token input)) ))))))

(defun perror (input-stream fmt &rest args)
  (describe input-stream)
  (error "Parse error at (~A:~D): ~A"
         (ignore-errors (pathname (input-stream-stream input-stream)))
         (ignore-errors (file-position (input-stream-stream input-stream)))
         (apply #'format nil fmt args)))

;;;;

(defun read-group-rest (input)
  "While the first :GROUP-BEGIN is already read, read the remaining of the group,
   and return the list of tokens."
  (let ((nesting 1)
        (res nil))
    (loop
      (let ((tok (read-token input)))
        (case (token-category tok)
          (:group-begin (incf nesting))
          (:group-end   (decf nesting))
          (:eof
           (perror input "EOF while seeking for end of group.")))
        (when (zerop nesting)
          (return)) ;all done
        (push tok res)))
    (reverse res)))

(defun chop-off-group (tokens)
  "Given a list of tokens, chop off a group. Returns two values the
tokens in the group and the remaining input."
  (let ((nesting 0)
        (res nil))
    (loop
        (let ((tok (pop tokens)))
          (cond ((null tok)
                 (error "Out of tokens."))
                (t
                 (case (token-category tok)
                   (:group-begin
                    (unless (zerop nesting)
                      (push tok res))
                    (incf nesting))
                   (:group-end
                    (decf nesting)
                    (unless (zerop nesting)
                      (push tok res)))
                   (otherwise
                    (push tok res)))))
          (when (zerop nesting)
            (return))))                 ;all done
    (values
     (reverse res)
     tokens)))

(defun unread-token (token input)
  "Unreads a token to a tex-stream."
  (push token (input-stream-token-lookahead input)))

(defun peek-token (input)
  (let ((tok (read-token input)))
    (unread-token tok input)
    tok))

(defun test-match (template input)
  (match-parameters
   (let ((i (make-tex-input (make-string-input-stream template))))
     (loop for x = (read-token i) until (eq (car x) :eof) collect x))
   (make-tex-input (make-string-input-stream input))))

(defun match-parameters (template input)
  ;; Missing: Stuff like "\def\foo#1#{blah}" See §476 in tex.web.
  (cond ((null template)
         nil)
        ((not (eq (token-category (first template)) :param))
         (let ((tok (read-token input)))
           (unless (token-equal tok (first template))
             (perror input "Mismatch while matching parameters: Expected ~S, got ~S."
                     (first template)
                     tok)))
         (match-parameters (cdr template) input))
        ;;
        ((eq :optional (param-kind (token-value (first template))))
         ;; LaTeX optional parameter
         ;; XXX This needs more testing with the real LaTeX rules.
         (labels ((at-lbracket-p ()
                    (let ((tok (read-token input)))
                      (let ((res (cond ((eq :eof (token-category tok))
                                        nil)
                                       ((token-equal tok (make-token :char #\[))
                                        t)
                                       ((token-equal tok (make-token :space))
                                        (at-lbracket-p))
                                       (t
                                        nil))))
                        (unless res
                          (unread-token tok input))
                        res))))
           ;;
           (cond ((at-lbracket-p)
                  ;;(read-token input)    ;consume the #\[
                  (prog1
                      (cons (first
                             (match-parameters (list (make-token :param '(:required 1))
                                                     (make-token :char #\]))
                                               input))
                            (match-parameters (cdr template) input))
                    ;; skip space tokens
                    (do () ((not (eql :space (token-category (peek-token input)))))
                      (read-token input)) ))
                 (t
                  ;; not present, skip this
                  (cons (param-default (token-value (first template)))
                        (match-parameters (cdr template) input))))))
        ;;
        (t
         (let* ((current-value nil)
                (postion-of-next-arg (or (position :param template :start 1 :key #'token-category)
                                         (length template)))
                (delimiter (subseq template
                                   1 postion-of-next-arg)))
           (block scanning
             (labels ((insert-token-and-test-for-delimiter (tok)
                        ;; Add the current token to the argument
                        (cond ((eq :group-begin (token-category tok))
                               ;; Read a whole group
                               (setf current-value
                                     (nconc current-value (read-group-rest input))))
                              (t
                               (setf current-value (nconc current-value (list tok)))) )
                        ;; When the tail of current-value matches delimiter, we have completed
                        ;; the argument.
                        (when (and (>= (length current-value) (length delimiter))
                                   (every #'token-equal
                                          (append (subseq current-value (- (length current-value)
                                                                           (length delimiter)))
                                                  (list tok))
                                          delimiter))
                          (return-from scanning
                            (cons (subseq current-value 0 (- (length current-value)
                                                             (length delimiter)))
                                  (match-parameters (subseq template postion-of-next-arg)
                                                    input))))))
               (loop
                 (let ((tok (read-token input)))
                   ;; Special rule for spaces and undelimited tokens:
                   (cond ((and (eq :space (token-category tok))
                               (null delimiter))
                          ;; just ignore this
                          )
                         ((eq :par (token-category tok))
                          (cond ((every #'token-equal (list (make-token :space)) delimiter)
                                 ;; special case, if the delimiter is a space, we also accept \par.
                                 (cond ((= postion-of-next-arg (length template))
                                        ;; Also, if this is the very last macro parameter, leave
                                        ;; the \par token in the input.
                                        (unread-token tok input)))
                                 ;; now we have completed the parameter, continue parsing the
                                 ;; next one.
                                 (return (cons current-value
                                               (match-parameters (subseq template
                                                                         postion-of-next-arg)
                                                                 input))))
                                (t
                                 ;; otherwise
                                 (insert-token-and-test-for-delimiter tok))))
                         (t
                          (insert-token-and-test-for-delimiter tok)) ))) ))))))

;;;;

(defun read-/def (input)
  (let ((tok (read-token input)))
    (unless (eq :cs (token-category tok))
      (perror input "Expected cs-token after \\def -- got ~S." tok))
    (let ((name (token-value tok)))
      (let ((arglist (read-parameter-template input)))
        (do-/def name arglist (read-group-rest input))))))

(defun read-parameter-template (input)
  (let ((arglist nil))
    (do ((q (read-token input)
            (read-token input)))
        ((or (eq :group-begin (token-category q))
             (eq :eof (token-category q)))
         (reverse arglist))
      ;; ignore leading spaces
      (unless (and (null arglist)
                   (eq :space (token-category q)))
        (push q arglist)))))

;;;; Macros

(defvar *tex-macros*
  (make-hash-table :test #'equal))

(defun apply-tex-macro (macro-name input-stream)
  ;; Applies the macro called 'macro-name'
  (let ((fn (or (gethash macro-name *tex-macros*)
                (error "There is no such macro: ~S." macro-name))))
    (let ((expansion (funcall fn input-stream)))
      (unread-tokens expansion input-stream)
      (values))))

(defun unread-tokens (tokens input)
  (setf (input-stream-token-lookahead input)
        (append tokens
                (input-stream-token-lookahead input))))

(defun read-and-subst-parameters (name input template expansion)
  (let ((parameters (match-parameters template input)))
    (mapcan (lambda (tok)
              (cond ((eq :param (token-category tok))
                     (cond ((<= 1 (param-n (token-value tok)) (length parameters))
                            (copy-list (elt parameters (- (param-n (token-value tok)) 1))))
                           (t
                            (error "While expanding ~S: No such macro parameter: #~D"
                                   name (param-n (token-value tok))))))
                    (t
                     (list tok))))
            expansion)))

(defmacro named-lambda (name args &body body)
  `(labels ((,name ,args ,@body))
     #',name))

(defun fdefine-tex-macro (name parameter-template expansion)
  (setf (gethash name *tex-macros*)
        (lambda (input-stream)
          (read-and-subst-parameters name input-stream parameter-template expansion))))

(defmacro define-tex-macro (name template lambda-list &body body)
  `(let ((template (read-parameter-template
                    (make-tex-input (make-string-input-stream ,template)))))
     (setf (gethash ,name *tex-macros*)
           #'(lambda ($input)
               (destructuring-bind ,lambda-list (match-parameters template $input)
                 ,@body)))))

(defmacro define-ignore (name template)
  `(define-tex-macro ,name ,template (&rest ignore)
     (declare (ignore ignore))
     nil))

(defun do-/def (name parameter-template expansion)
  (print `(:/def ,name))
  (cond ((gethash name *tex-macros*)
         (or (member name '("Dodocf" "Dodocv" "dodocf" "dodocv")
                     :test #'string=))
         '(format T "~&;; _not_ defining TeX Macro ~S.~%" name))
        (t
         '(format T "~&;; Defining TeX Macro ~S.~%" name)
         (fdefine-tex-macro name parameter-template expansion)))
  nil)

(defvar *stop-words* nil)
(defvar *undefined-macros* nil)
(defvar *math-mode-p* nil)

(defun ts (string)
  (slurp-stream (make-tex-input (make-string-input-stream string))))
(defun tf (filename)
  (with-open-file (input filename)
    (slurp-stream (make-tex-input input))))

(defun slurp-stream (input)
  (let ((res nil))
    (labels ((add (x)
               (cond ((characterp x)
                      (if (stringp (car res))
                        (setf (car res) (concatenate 'string (car res) (string x)))
                        (push (string x) res)))
                     (t
                      (push x res)))))

      (do ((tok (read-token input) (read-token input)))
          ((or (eq :eof (token-category tok))
               (eq :group-end (token-category tok))))
        (case (token-category tok)
          (:cs
           (cond ((member (token-value tok) *stop-words* :test #'string=)
                  (unread-token tok input)
                  (return))
                 (t
                  (let ((f (gethash (token-value tok) *tex-macros*)))
                    (if f
                      (apply-tex-macro (token-value tok) input)
                      (progn
                        (unless (member (token-value tok) *undefined-macros*
                                        :test #'string=)
                          (warn "Macro ~S not defined." (token-value tok)))
                        (pushnew (token-value tok) *undefined-macros*
                                 :test #'string=) ))) )))
          ;;
          (:group-begin
           (add `(:GROUP ,@(slurp-stream input))))

          ;;
          (:space
           (unless *math-mode-p*
             (add #\space)))
          ;;
          (:char
           (cond ((and *math-mode-p* (find (token-value tok) "+-="))
                  (add +nbsp+)
                  (add (token-value tok))
                  (add +nbsp+))
                 ((and *math-mode-p* (digit-char-p (token-value tok)))
                  (add `(:RM
                         ,(string (token-value tok)))))
                 (t
                  (add (token-value tok)))))
          ;;
          (:noexpand
           ;; special token
           (mapc #'add (token-value tok)))
          
          (:wrap
           (add tok))
          ;;
          ((:param)
           (perror input "Stray macro parameter."))
          ;;
          ((:par)
           (add '(:PAR)))                 ;hard coded ;-(
          ;;
          ((:math)
           (cond (*math-mode-p*
                  (return))
                 (t
                  (cond ((token-equal (peek-token input) (make-token :math))
                         ;; display math
                         (let ((*math-mode-p* t))
                           (read-token input)
                           (add (progn `(:DISPMATH
                                         ,@(slurp-stream input))))
                           (assert (token-equal (read-token input)
                                                (make-token :math)))))
                        (t
                         (let ((*math-mode-p* t))
                           (add (progn `(:MATH
                                         ,@(slurp-stream input))))))))))

          ((:subscript :superscript)
           (cond ((not *math-mode-p*)
                  '(perror input "Subscript in non-math mode."))
                 (t
                  (let ((q (match-parameters (list (make-token :param '(:required 1))) input)))
                    (add (progn `(,(ecase (token-category tok)
                                          (:subscript :SUB)
                                          (:superscript :SUP))
                                  ,@(slurp-stream
                                          (make-input-stream
                                           :token-lookahead (car q)
                                           :stream (make-concatenated-stream))))))))))
          ;;
          (otherwise
           (add (cons (node-gi tok)
                      (append (node-attributes tok)
                              (slurp-stream
                               (make-input-stream
                                :token-lookahead (node-children tok)
                                :stream (make-concatenated-stream))))))) )))
    (reverse res)))
           
(defun skot (tokens)
  (with-output-to-string (bag)
    (dolist (tok tokens)
      (ecase (token-category tok)
        ((:char) (write-char (token-value tok) bag))
        ((:space) (write-char #\space bag))
        ((:subscript) (write-char #\_ bag))
        ((:cs)    (write-char #\\ bag) (write-string (token-value tok) bag))))))

(defun expand-tokens (tokens)
  (slurp-stream (make-input-stream :token-lookahead tokens
                                   :stream (make-concatenated-stream))))

(defmacro let-tex-macro ((name deposited-name)
                         &body body)
  (let ((old (gensym)))
    `(let ((,old (gethash ,name *tex-macros*)))
       (unwind-protect
           (progn
             (setf (gethash ,name *tex-macros*)
                   (gethash ,deposited-name *tex-macros*))
             (locally ,@body))
         (setf (gethash ,name *tex-macros*) ,old)))))

(defmacro define-environment (name arg-spec args &body body)
  `(progn
    (define-tex-macro ,(format nil " begin ~A" name) ,arg-spec ,args
      (let (($body (slurp-stream $input)))
        ,@body))
    (define-tex-macro ,(format nil " end ~A" name) "" ()
      (list (make-token :eof)))))
