;;; -*- Mode: Lisp; Package: CLIMACS-LR-SYNTAX -*-

;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

(in-package :climacs-lr-syntax)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; the syntax object

(define-syntax lr-syntax (basic-syntax)
  ((scan)
   (stack-top :initform nil)
   (potentially-valid-trees)
   (lookahead-lexeme :initform nil :accessor lookahead-lexeme)
   (current-state))
  (:name "LR syntax"))

(defmethod initialize-instance :after ((syntax lr-syntax) &rest args)
  (declare (ignore args))
  (with-slots (buffer scan) syntax
     (setf scan (clone-mark (low-mark buffer) :left))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer

(defgeneric skip-inter (syntax state scan)
  (:documentation "advance scan until the beginning of a new
    lexeme.  Return T if one can be found and NIL otherwise."))

(defgeneric lex (syntax state scan)
  (:documentation "Return the next lexeme starting at scan."))

(defclass lexer-state ()
  ()
  (:documentation "These states are used to determine how the lexer 
    should behave."))

(defmacro define-lexer-state (name superclasses &body body)
  `(defclass ,name (,@superclasses lexer-state)
      ,@body))

;; FIXME: is this a reasonable default, or should be put back to
;; lisp-syntax.lisp? --ns
(defmethod skip-inter ((syntax lr-syntax) state scan)
  (declare (ignore state))
  (macrolet ((fo () `(forward-object scan)))
    (loop when (end-of-buffer-p scan)
	    do (return nil)
	  until (not (whitespacep (object-after scan)))
	  do (fo)
	  finally (return t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; this should inherit from parse-tree

(defclass parser-symbol ()
  ((start-mark :initform nil :initarg :start-mark :reader start-mark)
   (size :initform nil :initarg :size)
   (parent :initform nil :accessor parent)
   (children :initform '() :initarg :children :reader children)
   (preceding-parse-tree :initform nil :reader preceding-parse-tree)
   (parser-state :initform nil :initarg :parser-state :reader parser-state)))

(defmethod start-offset ((state parser-symbol))
  (let ((mark (start-mark state)))
    (when mark
      (offset mark))))

(defmethod end-offset ((state parser-symbol))
  (with-slots (start-mark size) state
     (when start-mark
       (+ (offset start-mark) size))))

(defgeneric action (syntax state lexeme))
(defgeneric new-state (syntax state parser-symbol))

(defclass parser-state () ())

(defmacro define-parser-state (name superclasses &body body)
  `(progn 
     (defclass ,name ,superclasses
	  ,@body)
     (defvar ,name (make-instance ',name))))

(defclass lexeme (parser-symbol) ())

(defmethod print-object ((lexeme lexeme) stream)
  (print-unreadable-object (lexeme stream :type t :identity t)
    (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme))))

(defclass nonterminal (parser-symbol) ())

(defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args)
  (declare (ignore args))
  (with-slots (children start-mark size) parser-symbol
     (loop for child in children
	   do (setf (parent child) parser-symbol))
     (let ((start (find-if-not #'null children :key #'start-offset))
	   (end (find-if-not #'null children :key #'end-offset :from-end t)))
       (when start
	 (setf start-mark (slot-value start 'start-mark)
	       size (- (end-offset end) (start-offset start)))))))  

(defmethod lex :around (syntax state scan)
  (when (skip-inter syntax state scan)
    (let* ((start-offset (offset scan))
	   (lexeme (call-next-method))
	   (new-size (- (offset scan) start-offset)))
      (with-slots (start-mark size) lexeme
	 (setf (offset scan) start-offset)
	 (setf start-mark scan
	       size new-size))
      lexeme)))		  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser

(defmacro define-action (syntax (state lexeme) &body body)
  `(defmethod action ((syntax ,syntax) (state ,state) (lexeme ,lexeme))
     ,@body))

(defmacro define-new-state (syntax (state parser-symbol) &body body)
  `(defmethod new-state ((syntax ,syntax) (state ,state) (tree ,parser-symbol))
     ,@body))

(defmacro define-initial-parser-state (syntax state)
  `(defmethod initial-parser-state ((syntax ,syntax))
     ,state))

(defun pop-one (syntax)
  (with-slots (stack-top current-state) syntax
     (with-slots (preceding-parse-tree parser-state) stack-top
	(prog1 stack-top
	       (setf current-state parser-state
		     stack-top preceding-parse-tree)))))

(defun pop-number (syntax how-many)
  (loop with result = '()
	repeat how-many
	do (push (pop-one syntax) result)
	finally (return result)))

(defmacro reduce-fixed-number (symbol nb-children)
  `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children))))
     (when (zerop ,nb-children)
       (with-slots (scan) syntax
	  (with-slots (start-mark size) result
	     (setf start-mark (clone-mark scan :right)
		   size 0))))
     result))

(defun pop-until-type (syntax type)
  (with-slots (stack-top) syntax
     (loop with result = '()
	   for child = stack-top
	   do (push (pop-one syntax) result)
	   until (typep child type)
	   finally (return result))))

(defmacro reduce-until-type (symbol type)
  `(let ((result (make-instance ',symbol
		    :children (pop-until-type syntax ',type))))
     (when (null (children result))
       (with-slots (scan) syntax
	  (with-slots (start-mark size) result
	     (setf start-mark (clone-mark scan :right)
		   size 0))))
     result))

(defun pop-all (syntax)
  (with-slots (stack-top) syntax
     (loop with result = '()
	   until (null stack-top)
	   do (push (pop-one syntax) result)
	   finally (return result))))

(defmacro reduce-all (symbol)
  `(let ((result (make-instance ',symbol :children (pop-all syntax))))
     (when (null (children result))
       (with-slots (scan) syntax
	  (with-slots (start-mark size) result
	     (setf start-mark (clone-mark scan :right)
		   size 0))))
     result))     

;;;
;;; Grammar definition
;;;

(defmacro define-grammar (syntax options &rest grammar-clauses)
  (let ((parser-state-superclasses (list))
        (nonterminal-superclasses (list))
        (code (list)))
    (labels ((symbol-equalp (x1 x2)
               (and (symbolp x1) (string= x1 x2)))
             (treate-define-state-clause (clause)
               "Recognize if CLAUSE is a parser state definition:
                (<state-super-class> => <state-class>)
                If it is, push <state-super-class> into <state-class>'s
                super class list; otherwise, NIL is returned."
               (when (= 3 (length clause))
                 (destructuring-bind (super-class op class) clause
                     (when (and (symbol-equalp op '=>)
                                (symbolp super-class)
                                (symbolp class))
                       (if (assoc class parser-state-superclasses)
                           (push super-class (cdr (assoc class parser-state-superclasses)))
                           (push (cons class (list super-class)) parser-state-superclasses))
                       (assoc class parser-state-superclasses)))))
             (treate-define-new-state-clause (clause)
               "Recognize if CLAUSE is a new state definition:
                (<new-state> => <state> <parser-symbol>)
                If it is, push the according DEFINE-NEW-STATE form
                in CODE; otherwise NIL is returned."
               (when (= 4 (length clause))
                 (destructuring-bind (new-state op state parser-symbol) clause
                     (when (and (symbol-equalp op '=>)
                                (symbolp new-state)
                                (symbolp state)
                                (symbolp parser-symbol))
                       (push `(define-new-state ,syntax (,state ,parser-symbol)
                                ,new-state)
                             code)))))
             (treate-define-nonterminal-clause (clause)
               "Recognize if CLAUSE is a nonterminal definition:
                (<nonterminal-superclass> -> <nonterminal-class>)
                If it is, push <nonterminal-superclass> into <nonterminal-class>'s
                super class list; otherwise, NIL is returned."
               (when (= 3 (length clause))
                 (destructuring-bind (super-class op class) clause
                     (when (and (symbol-equalp op '->)
                                (symbolp super-class)
                                (symbolp class))
                       (if (assoc class nonterminal-superclasses)
                           (push super-class (cdr (assoc class nonterminal-superclasses)))
                           (push (cons class (list super-class)) nonterminal-superclasses))
                       (assoc class nonterminal-superclasses)))))
             (treate-define-action-clause (clause)
               "Recognize if CLAUSE is a nonterminal action rule:
                (<nonterminal> -> <state> <lexeme> <action-keyword> [action-args])
                If it is, push the according DEFINE-ACTION form in CODE;
                otherwise NIL is returned."
               (when (<= 4 (length clause))
                 (destructuring-bind (nonterminal op state lexeme action-keyword &rest action-args) 
                     clause
                   (when (symbol-equalp op '->)
                     (push `(define-action ,syntax (,state ,(or lexeme '(eql nil)))
                              ,(ccase action-keyword
                                      (:reduce-until-type 
                                       `(reduce-until-type ,nonterminal ,(first action-args)))
                                      (:reduce-fixed-number
                                       `(reduce-fixed-number ,nonterminal ,(first action-args)))
                                      (:reduce-all
                                       `(reduce-all ,nonterminal))
                                      (:done
                                       `(throw 'done nil))))
                           code)))))
             (treate-options (&key initial-state &allow-other-keys)
               (when initial-state
                 (push `(define-initial-parser-state ,syntax ,initial-state)
                       code))))
      (dolist (clause grammar-clauses)
        (or (treate-define-state-clause clause)
            (treate-define-new-state-clause clause)
            (treate-define-nonterminal-clause clause)
            (treate-define-action-clause clause)
            (error "~S is not a valid grammar clause" clause)))
      (apply #'treate-options options)
      `(progn
         ,@(loop for (state . superclasses) in (reverse parser-state-superclasses)
              collect `(define-parser-state ,state (,@superclasses) ()))
         ,@(loop for (nonterminal . superclasses) in (reverse nonterminal-superclasses)
              collect `(defclass ,nonterminal (,@superclasses) ()))
         ,@(reverse code)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser step

(defgeneric parser-step (syntax))

(defmethod parser-step ((syntax lr-syntax))
  (with-slots (lookahead-lexeme stack-top current-state scan) syntax
     (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right)))
     (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme))
	    (new-state (new-state syntax current-state new-parser-symbol)))
       (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol
	  (setf parser-state current-state
		current-state new-state
		preceding-parse-tree stack-top
		stack-top new-parser-symbol)))
     (setf (offset scan) (end-offset stack-top))))

(defun prev-tree (tree)
  (assert (not (null tree)))
  (if (null (children tree))
      (preceding-parse-tree tree)
      (car (last (children tree)))))

(defun next-tree (tree)
  (assert (not (null tree)))
  (if (null (parent tree))
      nil
      (let* ((parent (parent tree))
	     (siblings (children parent)))
	(cond ((null parent) nil)
	      ((eq tree (car (last siblings))) parent)
	      (t (loop with new-tree = (cadr (member tree siblings :test #'eq))
		       until (null (children new-tree))
		       do (setf new-tree (car (children new-tree)))
		       finally (return new-tree)))))))	 

(defun find-last-valid-lexeme (parse-tree offset)
  (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil)
	((> (start-offset parse-tree) offset)
	 (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
	((not (typep parse-tree 'lexeme))
	 (find-last-valid-lexeme (car (last (children parse-tree))) offset))
	((>= (end-offset parse-tree) offset)
	 (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
	(t parse-tree)))  

(defun find-first-potentially-valid-lexeme (parse-trees offset)
  (cond ((null parse-trees) nil)
	((or (null (start-offset (car parse-trees)))
	     (< (end-offset (car parse-trees)) offset))
	 (find-first-potentially-valid-lexeme (cdr parse-trees) offset))
	((not (typep (car parse-trees) 'lexeme))
	 (find-first-potentially-valid-lexeme (children (car parse-trees)) offset))
	((<= (start-offset (car parse-trees)) offset)
	 (loop with tree = (next-tree (car parse-trees))
	       until (or (null tree) (> (start-offset tree) offset))
	       do (setf tree (next-tree tree))
	       finally (return tree)))
	(t (car parse-trees))))

(defun parse-tree-equal (tree1 tree2)
  (and (eq (class-of tree1) (class-of tree2))
       (eq (parser-state tree1) (parser-state tree2))
       (= (end-offset tree1) (end-offset tree2))))
  
(defmethod print-object ((mark mark) stream)
  (print-unreadable-object (mark stream :type t :identity t)
    (format stream "~s" (offset mark))))

(defun parse-patch (syntax)
  (with-slots (current-state stack-top scan potentially-valid-trees) syntax
     (parser-step syntax)
     (finish-output *trace-output*)
     (cond ((parse-tree-equal stack-top potentially-valid-trees)
	    (unless (or (null (parent potentially-valid-trees))
			(eq potentially-valid-trees
			    (car (last (children (parent potentially-valid-trees))))))
	      (loop for tree = (cadr (member potentially-valid-trees
					     (children (parent potentially-valid-trees))
					     :test #'eq))
		      then (car (children tree))
		    until (null tree)
		    do (setf (slot-value tree 'preceding-parse-tree)
			     stack-top))
	      (setf stack-top (prev-tree (parent potentially-valid-trees))))
	    (setf potentially-valid-trees (parent potentially-valid-trees))
	    (setf current-state (new-state syntax (parser-state stack-top) stack-top))
	    (setf (offset scan) (end-offset stack-top)))
	   (t (loop until (or (null potentially-valid-trees)
			      (>= (start-offset potentially-valid-trees)
				  (end-offset stack-top)))
		    do (setf potentially-valid-trees
			     (next-tree potentially-valid-trees)))))))	    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax

(defmethod update-syntax (buffer (syntax lr-syntax))
  (let* ((low-mark (low-mark buffer))
	 (high-mark (high-mark buffer)))
    (when (mark<= low-mark high-mark)
      (catch 'done
	(with-slots (current-state stack-top scan potentially-valid-trees) syntax
	   (setf potentially-valid-trees
		 (if (null stack-top)
		     nil
		     (find-first-potentially-valid-lexeme (children stack-top)
							  (offset high-mark))))
	   (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark)))
	   (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
		 current-state (if (null stack-top)
				   (initial-parser-state syntax)
				   (new-state syntax
					      (parser-state stack-top)
					      stack-top)))
	   (loop do (parse-patch syntax)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; display

(defgeneric display-parse-tree (parse-symbol syntax pane))

(defmethod display-parse-tree ((parse-symbol (eql nil)) syntax pane)
  (declare (ignore syntax pane))
  nil)

(defmethod display-parse-tree :around (parse-symbol syntax pane)
  (declare (ignore syntax))
  (with-slots (top bot) pane
     (when (and (start-offset parse-symbol) 
		(mark< (start-offset parse-symbol) bot)
		(mark> (end-offset parse-symbol) top))
       (call-next-method))))  

(defmethod display-parse-tree (parse-symbol syntax pane)
  (loop for child in (children parse-symbol)
	do (display-parse-tree child syntax pane)))
