;;;  lalr.lisp
;;;
;;;  This is an LALR parser generator.
;;;  (c) 1988 Mark Johnson. mj@cs.brown.edu
;;;  This is *not* the property of Xerox Corporation!

;; This is a modified version of the lalr.cl as found with the CMU AI Repository at
;; <https://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/parsing/lalr/>

;; Used with permission under the MIT license:

;;    Permission is hereby granted, free of charge, to any person obtaining
;;    a copy of this software and associated documentation files (the
;;    "Software"), to deal in the Software without restriction, including
;;    without limitation the rights to use, copy, modify, merge, publish,
;;    distribute, sublicense, and/or sell copies of the Software, and to
;;    permit persons to whom the Software is furnished to do so, subject to
;;    the following conditions:
;; 
;;    The above copyright notice and this permission notice shall be
;;    included in all copies or substantial portions of the Software.
;; 
;;    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;    EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;    MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;    IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;    CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;    TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;    SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;;  Modified to cache the first terminals, the epsilon derivations
;;;  the rules that expand a category, and the items that expand
;;;  a category

;;;  There is a sample grammar at the end of this file.
;;;  Use your text-editor to search for "Test grammar" to find it.

;;; (in-package 'LALR)
;;; (export '(make-parser lalr-parser *lalr-debug* grammar lexforms $ parse))

;;; (shadow '(first rest))
;;; (defmacro first (x) `(car ,x))
;;; (defmacro rest (x) `(cdr ,x))

;;;  The external interface is MAKE-PARSER.  It takes three arguments, a
;;;  CFG grammar, a list of the lexical or terminal categories, and an
;;;  atomic end marker.  It produces a list which is the Lisp code for
;;;  an LALR(1) parser for that grammar.  If that list is compiled, then
;;;  the function LALR-PARSER is defined.  LALR-PARSER is a function with
;;;  two arguments, NEXT-INPUT and PARSE-ERROR.
;;;
;;;  The first argument to LALR-PARSER, NEXT-INPUT must be a function with
;;;  zero arguments; every time NEXT-INPUT is called it should return
;;;  a CONS cell, the CAR of which is the category of the next lexical
;;;  form in the input and the CDR of which is the value of that form.
;;;  Each call to NEXT-INPUT should advance one lexical item in the
;;;  input.  When the input is consumed, NEXT-INPUT should return a
;;;  CONS whose CAR is the atomic end marker used in the call to MAKE-PARSER.
;;;
;;;  The second argument to LALR-PARSER, PARSE-ERROR will be called
;;;  if the parse fails because the input is ill-formed.
;;;
;;;
;;;  There is a sample at the end of this file.

;;;; Modifications

;; - Renamed specials to wear ear muffs
;; - Put into a package
;; - Support for operator precedence
;; - Considerable speedup in table construction
;; - Table-based driver

;; --Gilbert Baumann

#+(or)
(defpackage :de.bauhh.lalr
  (:use :cl)
  (:export #:make-parser                ;This is there for olde PARSE macro --- which needs to go away
           #:define-grammar             ;This should go away with time too.
           #:lalr-parse
           #:lalr-table
           ;; #:make-lalr-table
           #:lalr-table-p
           #:lalr-table-topcat
           #:lalr-table-states
           #:lalr-state
           #:make-lalr-state
           #:lalr-state-p
           #:lalr-state-name
           #:lalr-state-transitions
           #:lalr-action
           #:make-lalr-action
           #:lalr-action-categories
           #:lalr-action-goto
           #:reduce-action
           #:make-reduce-action
           #:reduce-action-p
           #:reduce-action-npop
           #:reduce-action-function
           #:shift-action
           #:make-shift-action
           #:shift-action-p))

#+(or)
(in-package :de.bauhh.lalr)

(in-package :nyala)

(eval-when (:compile-toplevel)
  (declaim (optimize (speed 3) (safety 1))))

(defvar *conflict-resolver*
  nil)

;;; definitions of constants and global variables used

(defvar *topcat* '$Start)
(defvar *end-marker*)

(defvar      *lex* nil
  "List of all lexemes (tokens). Usually keywords, but could be anything.")

(defvar *lex-vector* nil
  "Simple vector mapping a lexeme id to the lexeme itself.")

(defvar *lex-index* nil
  "The inverse of *LEX-VECTOR*. Mapping a lexeme to it's id.")

(defvar *lex-spelling* nil
  "An hash table mapping a lexeme keyword to its spelling, if known.")

(defvar      *rules*)
(defvar      *nrules*)
(defvar      *start*)
(defvar      *starts*)
(defvar      *cats*)
(defvar      *firsts*)
(defvar      *epsilons*)
(defvar      *expansions*)
(defvar      *lalr-debug* NIL "Inserts debugging code into parser if non-NIL")
(defvar      *state-list* '())
(defvar      *state-hash*)
(defvar      *precedence*)

(defparameter *next-state-no* -1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                    Rules and Grammars
;;;

(defstruct rule
  no mother daughters action
  options)

(defmethod print-object ((object rule) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (format stream "~@<~S ~_-> ~<~@{~S~^ ~_~}~:>~:>"
            (rule-mother object)
            (rule-daughters object))))

(defun transform-rule (rule no)
  (destructuring-bind (lhs rhs action options)
      rule
    (make-rule :no no
               :mother lhs
               :daughters rhs
               :action action
               :options options)))

(defun compute-expansion (cat)
  (remove-if-not #'(lambda (rule)
                     (eq (rule-mother rule) cat))
                 *rules*))

(defmacro expand (cat)
  `(gethash ,cat *expansions*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                    Properties of grammars

(defun get-all-cats (start)
  (labels ((try (deja-vu cat)
             (if (find cat deja-vu)
                 deja-vu
                 (try-rules (cons cat deja-vu) (compute-expansion cat))))
           (try-rules (deja-vu rules)
             (if rules
                 (try-rules (try-cats deja-vu (rule-daughters (car rules)))
                            (cdr rules))
                 deja-vu))
           (try-cats (deja-vu cats)
             (if cats
                 (try-cats (try deja-vu (car cats)) (cdr cats))
                 deja-vu)))
    (try '() start)))

(defun derives-eps (c)
  "t if c can be rewritten as the null string"
  (labels ((try (deja-vu cat)
             (unless (find cat deja-vu)
               (some #'(lambda (r)
                         (every #'(lambda (c1) (try (cons cat deja-vu) c1))
                                (rule-daughters r)))
                     (expand cat)))))
    (try '() c)))

(declaim (inline derives-epsilon))
(defun derives-epsilon (c)
  "looks up the cache to see if c derives the null string"
  (member c *epsilons* :test 'eq))

(declaim (inline cat-firsts))
(defun cat-firsts (cat)
  (gethash cat *starts*))

(defun first-terms (cat-list)
  "the leading terminals of an expansion of cat-list"
  (assert (= 1 (length cat-list)))
  (labels ((first-ds (cats)
             (if cats
                 (if (derives-epsilon (car cats))
                     (cons (car cats) (first-ds (cdr cats)))
                     (list (car cats)))))
           (try (deja-vu cat)
             (if (member cat deja-vu)
                 deja-vu
                 (try-list (cons cat deja-vu)
                           (mapcan #'(lambda (r)
                                       (first-ds (rule-daughters r)))
                                   (expand cat)))))
           (try-list (deja-vu cats)
             (if cats
                 (try-list (try deja-vu (car cats)) (cdr cats))
                 deja-vu)))
    (remove-if-not #'(lambda (term)
                       (or (eq *end-marker* term)
                           (find term *lex*)))
                   (try-list '() (first-ds cat-list)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                  LALR(1) parsing table constructor
;;;

(defstruct (item (:constructor cons-item (rule pos la)))
  rule pos la)
(defstruct citem rule pos la)

(defmacro item-daughters (i) `(rule-daughters (item-rule ,i)))
(defmacro citem-daughters (i) `(rule-daughters (citem-rule ,i)))

(defmacro item-right (i) `(nthcdr (item-pos ,i) (item-daughters ,i)))
(defmacro citem-right (i) `(nthcdr (citem-pos ,i) (citem-daughters ,i)))

(defmacro item-equal (i1 i2)
  `(and (eq (item-rule ,i1) (item-rule ,i2))
        (= (item-pos ,i1) (item-pos ,i2))
        (eq (item-la ,i1) (item-la ,i2))))

(defun item-core-equal (c1 c2)
  "T if the cores of c1 and c2 are equal"
  (and (eq (item-rule c1) (item-rule c2))
       (= (item-pos c1) (item-pos c2))))

(defun citem-core-equal (c1 c2)
  "T if the cores of c1 and c2 are equal"
  (and (eq (citem-rule c1) (citem-rule c2))
       (= (citem-pos c1) (citem-pos c2))))

(defun citem-item-core-equal (c1 c2)
  "T if the cores of c1 and c2 are equal"
  (and (eq (citem-rule c1) (item-rule c2))
       (= (citem-pos c1) (item-pos c2))))

(defun shift-citems (items cat)
  "shifts a set of items over cat"
  (labels ((shift-item (item)
             (if (eq (first (citem-right item)) cat)
                 (make-citem :rule (citem-rule item)
                             :pos (1+ (citem-pos item))
                             :la (citem-la item)))))
    (let ((new-items '()))
      (dolist (i items)
        (let ((n (shift-item i)))
          (if n
              (push n new-items))))
      new-items)))

(defun items-right (items)
  "returns the set of categories appearing to the right of the dot"
  (let ((right '()))
    (dolist (i items)
      (let ((d (first (item-right i))))
        (if (and d (not (find d right)))
          (push d right))))
    right))

(defun citems-right (items)
  "returns the set of categories appearing to the right of the dot"
  (let ((right '()))
    (dolist (i items)
      (let ((d (first (citem-right i))))
        (and d (pushnew d right))))
    right))

(defun compact-items (items)
  "collapses items with the same core to compact items"
  (let ((sofar '()))
    (dolist (i items)
      (let ((ci (dolist (s sofar)
                  (if (citem-item-core-equal s i)
                      (return s)))))
        (if ci
            (push (item-la i) (citem-la ci))
            (push (make-citem :rule (item-rule i)
                              :pos (item-pos i)
                              :la (list (item-la i)))
                  sofar))))
    (sort sofar #'<
          :key #'(lambda (i) (rule-no (citem-rule i))))))

(defun expand-citems (citems)
  "expands a list of compact items into items"
  (let ((items '()))
    (dolist (ci citems)
      (dolist (la (citem-la ci))
        (push (cons-item  (citem-rule ci)
                          (citem-pos ci)
                          la)
              items)))
    items))

(defun subsumes-citems (ci1s ci2s)
  "T if the sorted set of items ci2s subsumes the sorted set ci1s"
  (and (= (length ci1s) (length ci2s))
       (every #'(lambda (ci1 ci2)
                  (and (citem-core-equal ci1 ci2)
                       (subsetp (citem-la ci1) (citem-la ci2))))
              ci1s ci2s)))

(defun merge-citems (ci1s ci2s)
  "Adds the las of ci1s to ci2s.  ci2s should subsume ci1s"
  (mapcar #'(lambda (ci1 ci2)
              (setf (citem-la ci2) (union (citem-la ci1) (citem-la ci2))))
          ci1s ci2s)
  ci2s)

;;;  The actual table construction functions

(defstruct state name citems reduces shifts conflict)
(defstruct shift cat where)

;(defun lookup (citems)
;  "finds a state with the same core items as citems if it exits"
;  (find-if #'(lambda (state)
;               (and (= (length citems) (length (state-citems state)))
;                    (every #'(lambda (ci1 ci2)
;                               (item-core-equal ci1 ci2))
;                            citems (state-citems state))
;                    ))
;           *state-list*))

#+(OR)
(defun lookup (citems)
  "finds a state with the same core items as citems if it exits"
  (dolist (state *state-list*)
    (if (and (= (length citems) (length (state-citems state)))
             (do ((ci1s citems (cdr ci1s))
                  (ci2s (state-citems state) (cdr ci2s)))
                 ((null ci1s) t)
               (unless (citem-core-equal (car ci1s) (car ci2s))
                 (return nil))))
        (return state))))

(defun lookup (citems)
  "finds a state with the same core items as citems if it exits"
  (gethash (citems-key citems) *state-hash*))

(defun add-state (citems)
  "creates a new state and adds it to the state list"
  (let ((new-state
         (make-state :name (incf *next-state-no*)
                     :citems citems)))
    (push new-state *state-list*)
    (setf (gethash (citems-key citems) *state-hash*) new-state)
    new-state))

(defun citems-key (citems)
  (mapcan (lambda (citem)
            (list (citem-rule citem) (citem-pos citem)))
          citems))

(defun get-state-name (citems)
  "returns the state name for this set of items"
  (let* ((state (lookup citems)))
    (cond ((null state)
           (setq state (add-state citems))
           (build-state state citems))
          ((subsumes-citems citems (state-citems state))
           nil)
          (t
           (merge-citems citems (state-citems state))
           (follow-state citems)))
    (state-name state)))

(defun build-state (state citems)
  "creates the states that this state can goto"
  (let ((closure (close-citems citems)))
    (dolist (cat (citems-right closure))
      (push (make-shift :cat cat
                        :where (get-state-name (shift-citems closure cat)))
            (state-shifts state)))))

(defun follow-state (citems)
  "percolates look-ahead onto descendant states of this state"
  (let ((closure (close-citems citems)))
    (dolist (cat (citems-right closure))
      (get-state-name (shift-citems closure cat)))))

(defun build-table (start)
  "Actually builds the table"
  (setq *state-list* '())
  (setq *state-hash* (make-hash-table :test 'equal))
  (setq *next-state-no* -1)
  (get-state-name (list (make-citem :rule (make-rule :no 0
                                                     :mother *topcat*
                                                     :daughters (list start))
                                    :pos 0
                                    :la (list *end-marker*))))
  (setq *state-list* (nreverse *state-list*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                  LALR(1) parsing table printer
;;;

(defun print-table (*state-list*)
  "Prints the state table"
  (dolist (state *state-list*)
    (format t "~%~%~a:" (state-name state))
    (dolist (citem (state-citems state))
      (format t "~%  ~a -->~{ ~a~} .~{ ~a~}, ~{~a ~}"
              (rule-mother (item-rule citem))
              (subseq (rule-daughters (item-rule citem)) 0 (item-pos citem))
              (subseq (rule-daughters (item-rule citem)) (item-pos citem))
              (item-la citem)))
    (dolist (shift (state-shifts state))
      (format t "~%    On ~a shift ~a" (shift-cat shift) (shift-where shift)))
    (dolist (reduce (delete-if #'(lambda (i) (citem-right i))
                               (close-citems
                                (state-citems state))))
      (format t "~%    On~{ ~a~} reduce~{ ~a~} --> ~a"
              (citem-la reduce)
              (rule-daughters (citem-rule reduce))
              (rule-mother (citem-rule reduce)))))
  (format t "~%"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                  LALR(1) parser constructor
;;;

;;;  next-input performs lexical analysis.  It must return a cons cell.
;;;  its car holds the category, its cdr the value.

(defun close-citems (citems)
  "computes the closure of a set of items"
  (declare (optimize (speed 3) (safety 0)))
  (let ((sofar (make-array *nrules* :initial-element nil)))
    (declare (type (simple-array t (*)) sofar))
    (let ((todo nil))
      (declare (type list todo))
      (dolist (q (expand-citems citems))
        (push q todo))
      (do () ((null todo))
        (multiple-value-bind (rule pos la)
            (let ((i (pop todo)))
              (values (item-rule i) (item-pos i) (item-la i)))
          (let* ((rgt (nthcdr pos (rule-daughters rule))))
            (when rgt
              (let ((las (first-terminals-1 (rest rgt) la)))
                (dolist (r (expand (first rgt)))
                  (let ((ri (rule-no r)))
                    (declare (type fixnum ri))
                    (let* ((q (or (svref sofar ri)
                                  (setf (svref sofar ri)
                                        (let ((new (make-citem :rule r :pos 0)))
                                          (push new citems)
                                          new)))))
                      (let ((new-la (citem-la q))) 
                        (dolist (la las)
                          (unless (member la new-la :test 'eq)
                            (push la new-la)
                            (push (cons-item r 0 la) todo)))
                        (setf (citem-la q) new-la))))))))))))
  (sort (copy-list citems) #'< 
        :key #'(lambda (i) (rule-no (citem-rule i)))))

(defun build-parser-table-1 (state-list)
  (mapcar #'translate-state-1 state-list))

;;      table ::= ( { <state> }* )
;;      state ::= (<state> { <transition> }*)
;; transition ::= (<cat-list> :SHIFT <state-name>)
;;              | (<cat-list> :REDUCE <cat> <n> <action>)

(defun translate-state-1 (state)
  "translates a state into lisp code that could appear in a labels form"
  (let ((reduces (state-reduces state))
        (symbols-sofar '())) ; to ensure that a symbol never occurs twice
    (setf (state-reduces state) reduces)
    (labels ((translate-shift (shift)
               (push (shift-cat shift) symbols-sofar)
               `((,(shift-cat shift))
                 :shift
                 ,(shift-where shift)))
             (translate-reduce (item)
               #+(or)                   ;this is obsolete
               (when (intersection (citem-la item) symbols-sofar)
                 (fresh-line)
                 (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
                   (format t
                           "Warning, shift/reduce conflict: state ~a: ~a --> ~{~a ~} <*> ~{~a ~}~%"
                           (state-name state)
                           (rule-mother (citem-rule item))
                           (subseq (rule-daughters (citem-rule item)) 0 (citem-pos item))
                           (subseq (rule-daughters (citem-rule item)) (citem-pos item)) )
                   (format t "On ~@<~{~S~^, ~:_~}~:>"
                           (citem-la item)))
                 (terpri)
                 (force-output)
                 '(setf (citem-la item)
                       (set-difference (citem-la item)
                                       symbols-sofar)))
               (dolist (la (citem-la item))
                 (push la symbols-sofar))
               `(,(copy-list (citem-la item))
                  :reduce
                  ,(rule-mother (citem-rule item))
                  ,(citem-pos item)
                  ,(rule-action (citem-rule item)))))
      `(,(state-name state) 
         ,@(mapcar #'translate-shift (state-shifts state))
         ,@(mapcar #'translate-reduce reduces)))))

(defstruct (lalr-table (:constructor cons-lalr-table))
  topcat
  states)

(defstruct lalr-state
  name
  transitions)

(defstruct lalr-action
  categories
  goto)

(defstruct (reduce-action (:include lalr-action))
  npop
  function)

(defstruct (shift-action (:include lalr-action))
  )

;;;;;;;;;

(defun make-lalr-table (state-table)
  (cons-lalr-table
   :topcat (caar state-table)
   :states (coerce
            (mapcar (lambda (state)
                      (destructuring-bind (no &rest transitions) state
                        (make-lalr-state
                         :name no
                         :transitions
                         (mapcar (lambda (tr)
                                   (destructuring-bind (cats kind &rest more)
                                       tr
                                     (ecase kind
                                       (:shift
                                        (destructuring-bind (goto) more
                                          (make-shift-action :categories cats :goto goto)))
                                       (:reduce
                                        (destructuring-bind (goto npop action) more
                                          (make-reduce-action :categories cats
                                                              :goto goto
                                                              :npop npop
                                                              :function action))))))
                                 transitions))))
                    state-table)
            'vector)))

(defun grammar-lalr-table (lex rules &key (eof :eof))
  (make-lalr-table (grammar-state-table rules lex eof)))

;; There is a cache. If asked to compile the same grammar twice, we return
;; what we came up with. This speeds up development, when just the semantic
;; actions changed.

(defvar *last-grammar-req* nil)

(defun grammar-state-table (grammar lex end-marker)
  (let ((key (list grammar lex end-marker *conflict-resolver*)))
    (cdr
     (if (equal key (car *last-grammar-req*))
         *last-grammar-req*
         (setq *last-grammar-req*
               (cons key
                     (grammar-state-table-1 grammar lex end-marker)))))))

(defun grammar-state-table-1 (grammar lex end-marker)
  ;; For debugging:
  (set' *grammar* (list grammar lex end-marker))
  (set' *original-lex* lex)
  ;;
  (setq *end-marker* end-marker)
  (setq *precedence* nil)
  (setq *lex* nil)
  (setq *lex-spelling* (make-hash-table))
  (dolist (k lex)
    (if (consp k)
        (destructuring-bind (kw spelling) k
          (push kw *lex*)
          (setf (gethash kw *lex-spelling*) spelling))
        (push k *lex*)))
  ;; Pull precedence
  (setq grammar (remove-if (lambda (rule)
                             (cond ((typep rule '(cons (member :precedence) list))
                                    (dolist (prec (cdr rule))
                                      (etypecase prec
                                        ((cons (member :left :right :nonassoc) list)
                                         (setq *precedence* (nconc *precedence* (list prec))))))
                                    t)
                                   (t nil)))
                           grammar))
  ;; cache some data that will be useful later
  (setq *lex-vector* (coerce (cons *end-marker* *lex*) 'vector))
  (setq *lex-index* (make-hash-table :test 'eq))
  (loop for j from 0 for c across *lex-vector* do (setf (gethash c *lex-index*) j))
  (setq *start* (caar grammar))
  (setq *rules* (let ((i 0))
                  (mapcar #'(lambda (r) (transform-rule r (incf i)))
                          grammar)))
  (setq *nrules* (1+ (length *rules*)))
  (setq *cats* (get-all-cats *start*))
  (setq *expansions* (make-hash-table :test 'eq))
  (dolist (cat *cats*)
    (setf (gethash cat *expansions*) (compute-expansion cat)))
  (setq *epsilons* (remove-if-not #'derives-eps *cats*))
  (setq *starts* (make-hash-table :test 'eq))
  (dolist (cat (cons *end-marker* *cats*))
    (setf (gethash cat *starts*) (first-terms (list cat))))
  ;; now actually build the parser
  (build-table *start*)
  (when (and (listp *lalr-debug*) (member 'print-table *lalr-debug*))
    (print-table *state-list*))
  (format t "~&Table ready, ~D rules, ~D states, ~D terminals.~%"
          *nrules* (length *state-list*) (length *lex*))
  (force-output)
  (setq *state-list* (compute-reduces *state-list*))
  (setq *state-list* (resolve-conflicts *state-list*))
  (build-parser-table-1 *state-list*))

(defun first-terminals-1 (cat-list more &aux res)
  (declare (optimize (speed 3) (safety 0))
           (type list cat-list))
  (loop
    (cond ((null cat-list)
           (return (if res (union res (cat-firsts more)) (cat-firsts more))))
          ((derives-epsilon (first cat-list))
           (setf res (if res
                         (union res (cat-firsts (first cat-list)))
                         (cat-firsts (first cat-list))))
           (setq cat-list (rest cat-list)))
          (t
           (return (if res
                       (union res (cat-firsts (first cat-list)))
                       (cat-firsts (first cat-list))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                   Test grammar and lexical analyser
;;;

;;;  A Test grammar

#+(or)
(progn
  (lalr-define-grammar lalr-parser
    (det n v)
    (s --> np vp      #'(lambda (np vp) (list 's np vp)))
    (np --> det n     #'(lambda (det n) (list 'np det n)))
    (np -->           #'(lambda () '(np)))
    (vp --> v np      #'(lambda (v np) (list 'vp v np)))
    (vp --> v s       #'(lambda (v s) (list 'vp v s))))

  (defparameter *lexicon* '((the det)
                            (man n)
                            (woman n)
                            (cat n)
                            (dog n)
                            (loves v)
                            (thinks v)
                            (hates v)))

  (defun parse (words)
    (labels ((lookup (word)
               (cadr (assoc word *lexicon*)))
             (next-input ()
               (cond ((null words) :eof)
                     (t
                      (let* ((word (pop words))
                             (cat (lookup word)))
                        (values cat                ; category
                                (list cat word)))))) ; value
             (parse-error (msg)
               (format nil "Error before ~a: ~a" words msg)))
      (lalr-parser #'next-input #'parse-error))))

;;; *EOF*

;;;; -- Conflict Resolution -------------------------------------------------------------------

(defun compute-reduces (state-list)
  (dolist (state state-list state-list)
    (setf (state-reduces state) (delete-if #'(lambda (i) (citem-right i))
                                           (close-citems (state-citems state))))))

(defun default-conflict-resolver (cat shifts reduces)
  (let ((candidates (append shifts reduces)))
    (cond
      ((and (= 0 (length shifts)) (= 1 (length reduces)))
       reduces)
      ((and (= 1 (length shifts)) (= 0 (length reduces)))
       shifts)
      ;; Shift/reduce conflict
      ((and (= (length candidates) 2)
            (shift-p (car candidates))
            (item-p (cadr candidates)))
       (destructuring-bind (shift reduce) candidates
         (let ((shift-prec (precedence cat))
               (reduce-prec (some #'precedence (item-daughters reduce))))
           (let ((shift-rule-options
                  (remove-if (lambda (x)
                               (not (member (car x) '(:left :right :nonassoc)))) 
                             (mapcan (lambda (shift)
                                       (mapcan (lambda (x) (copy-list (rule-options x)))
                                               (mapcar 'citem-rule
                                                       (state-citems
                                                        (elt *state-list* (shift-where shift))))))
                                     shifts)))
                 (reduce-rule-options
                  (remove-if (lambda (x)
                               (not (member (car x) '(:left :right :nonassoc))))
                             (mapcan #'(lambda (x) (copy-list (rule-options (item-rule x))))
                                     reduces))))
             (let ((shift-prec (or (car shift-rule-options) shift-prec))
                   (reduce-prec (or (car reduce-rule-options) reduce-prec)))
               (cond ((and shift-prec reduce-prec
                           (and (cadr shift-prec) (cadr reduce-prec))
                           (> (cadr shift-prec) (cadr reduce-prec)))
                      (list shift))
                     ((and shift-prec reduce-prec
                           (and (cadr shift-prec) (cadr reduce-prec))
                           (< (cadr shift-prec) (cadr reduce-prec)))
                      (list reduce))
                     ((eq (car shift-prec) :left)
                      (list reduce))
                     ((eq (car shift-prec) :right)
                      (list shift))
                     ((eq (car shift-prec) :nonassoc)
                      (list shift))
                     ((eq (car reduce-prec) :left) ;??
                      (list reduce))
                     ((eq (car reduce-prec) :right) ;??
                      (list shift))
                     (t
                      (queue-report-conflict cat shifts reduces)
                      #+NIL (list shift)
                      candidates
                      )))))))
      (t
       ;; #-NIL (warn "Unresolvable conflict on ~S:~%~S" cat candidates)
       (queue-report-conflict cat shifts reduces)
       #+NIL
       (list (cond ((find-if #'shift-p candidates))
                   ((car (sort (copy-list candidates) #'<
                               :key (lambda (i)
                                      (rule-no (item-rule i))))))))
       candidates))))

(defvar *conflicts-found*
  nil
  "During RESOLVE-CONFLICTS all the conflicts found, so that a summary can be printed.
List of (<categories> <shifts> <reduces>).")

(defun resolve-conflicts (state-list &aux (*conflicts-found* nil))
  (prog1
      (loop for state in state-list
            for state-no from 0
            collect
            (let* ((all-cat
                    (remove-duplicates (append (mapcan (lambda (p)
                                                         (copy-list (citem-la p)))
                                                       (state-reduces state))
                                               (mapcar #'shift-cat (state-shifts state)))))
                   (new-transitions
                    (loop for cat in all-cat append
                          (let* ((shifts
                                  (remove cat (state-shifts state) :test-not 'eq :key #'shift-cat))
                                 (reduces
                                  (remove-if-not
                                   (lambda (p) (eq cat (item-la p)))
                                   (expand-citems (state-reduces state)))))
                            (if *conflict-resolver*
                                (funcall *conflict-resolver* cat shifts reduces)
                                (default-conflict-resolver cat shifts reduces))))))
              (setq state (copy-state state))
              (setf (state-shifts state)  (remove-if-not #'shift-p new-transitions)
                    (state-reduces state) (compact-items (remove-if-not #'item-p new-transitions)))
              state))
    (cond ((null *conflicts-found*)
           (format t "~%;; No conflicts~%"))
          (t
           (let ((msg
                  (with-output-to-string (bag)
                    (dolist (k *conflicts-found*)
                      (report-conflict (car k) (cadr k) (caddr k) bag)))))
             (warn "~D conflicts found, ~D reduce/reduce conflicts~%~A"
                   (length *conflicts-found*)
                   (count-if (lambda (q) (>= (length (third q)) 2)) *conflicts-found*)
                   msg))))))

(defun queue-report-conflict (cat shifts reduces)
  (labels ((conflict-key (q)
             (destructuring-bind (cat-list shifts reduces) q
               (declare (ignore cat-list))
               (list
                (mapcar (lambda (cand)
                          (when (shift-p cand)
                            (let ((citems (state-citems (elt *state-list* (shift-where cand)))))
                              (mapcar (lambda (citem)
                                        (list (citem-rule citem) (citem-pos citem)))
                                      citems))))
                        shifts)
                (mapcar (lambda (item)
                          (when (item-p item)
                            (list (item-rule item) (item-pos item))))
                        reduces)))))
    (let ((q
           (find (conflict-key (list cat shifts reduces)) *conflicts-found*
                 :key #'conflict-key
                 :test #'equal)))
      (if q
          (pushnew cat (car q))
          (push (list (list cat) shifts reduces) *conflicts-found*)))))

(defun report-conflict (cat-list shifts reduces &optional (stream *standard-output*))
  (when '(> (length reduces) 1)
    ;; This really needs to be nicer.
    (let ((*print-pretty* t)
          (*print-right-margin* 120))
      (format stream "~&~%=== Unresolvable shift/reduce conflict on ~@<~{~S~^, ~:_~}~:>:~%" (mapcar #'spelling cat-list))
      (when shifts
        (format stream "Shifts:~%")
        (dolist (cand shifts)
          (when (shift-p cand)
            (dolist (citem (state-citems (elt *state-list* (shift-where cand))))
              (write-string "    " stream)
              (show-citem citem stream)
              (terpri stream)))))
      (when reduces
        (format stream "Reduces:~%")
        (dolist (cand reduces)
          (cond ((item-p cand)
                 (write-string "    " stream)
                 (show-item cand stream)
                 (terpri stream))))))))

(defun show-citem (citem &optional (stream *standard-output*))
  (show-item-1 (citem-rule citem) (max 0 (1- (citem-pos citem))) stream))

(defun show-item (item &optional (stream *standard-output*))
  (show-item-1 (item-rule item) (item-pos item) stream))

(defun show-item-1 (rule pos stream)
  (let* ((daughters (rule-daughters rule)))
    (format stream "~A -> ~{~S~^ ~} . ~{~S~^ ~}"
            (rule-mother rule)
            (mapcar #'spelling (subseq daughters 0 pos))
            (mapcar #'spelling (subseq daughters pos)))))

#+NIL
(defun conflict-key (q)
  (destructuring-bind (cat-list shifts reduces) q
    (declare (ignore cat-list))
    (with-output-to-string (stream)
      (when shifts
        (format stream "Shifts:~%")
        (dolist (cand shifts)
          (when (shift-p cand)
            (dolist (citem (state-citems (elt *state-list* (shift-where cand))))
              (write-string "    " stream)
              (show-citem citem stream)
              (terpri stream)))))
      (when reduces
        (format stream "Reduces:~%")
        (dolist (cand reduces)
          (cond ((item-p cand)
                 (write-string "    " stream)
                 (show-item cand stream)
                 (terpri stream))))))))   

(defun spelling (cat)
  (gethash cat *lex-spelling* cat))

;;
;; (:precedence { :left | :right | :nonassoc } lexeme...)
;; 

(defun precedence (lexeme)
  ;; -> (<kind> <precedence-level>)
  (do ((i 0 (1+ i))
       (p *precedence* (cdr p)))
      ((null p) nil)
    (when (member lexeme (cdar p))
      (return (list (caar p) i)))))

;;;; ------------------------------------------------------------------------------------------

(defun lalr-parse (table next-input &optional action-vector)
  ;; (declare (optimize (speed 3) (safety 0)))
  (LET ((VAL-STACK '())                 ;value stack
        (STATE-STACK '())               ;state stack
        (CUR-STATE 0)                   ;current state
        CAT VAL
        ACTION)
    (TAGBODY
            (SETF (VALUES CAT VAL)
                  (FUNCALL NEXT-INPUT))
      :DISPATCH
            (SETQ ACTION (FIND CAT
                               (LALR-STATE-TRANSITIONS (SVREF (LALR-TABLE-STATES TABLE) CUR-STATE))
                               :KEY #'LALR-ACTION-CATEGORIES
                               :TEST #'MEMBER))
            (ETYPECASE ACTION
              (SHIFT-ACTION
               (PUSH CUR-STATE STATE-STACK)
               (PUSH VAL VAL-STACK)
               (SETF CUR-STATE (SHIFT-ACTION-GOTO ACTION))
               (SETF (VALUES CAT VAL)
                     (FUNCALL NEXT-INPUT))
               (GO :DISPATCH))
              (REDUCE-ACTION
               (WHEN (EQL (REDUCE-ACTION-GOTO ACTION) *TOPCAT*) ;hmm
                 (RETURN-FROM LALR-PARSE (POP VAL-STACK)))
               (LET ((DAUGHTER-VALUES '()))
                 (DOTIMES (I (THE FIXNUM (REDUCE-ACTION-NPOP ACTION)))
                   (PUSH (POP VAL-STACK) DAUGHTER-VALUES)
                   (SETQ CUR-STATE (POP STATE-STACK)))
                 (PUSH CUR-STATE STATE-STACK)
                 (LET* ((FUN (LET ((FUN (REDUCE-ACTION-FUNCTION ACTION)))
                               (IF (INTEGERP FUN) (ELT ACTION-VECTOR FUN) FUN))))
                   (PUSH (APPLY FUN DAUGHTER-VALUES) VAL-STACK))
                 (SETQ ACTION (FIND (REDUCE-ACTION-GOTO ACTION)
                                    (LALR-STATE-TRANSITIONS (SVREF (LALR-TABLE-STATES TABLE) CUR-STATE))
                                    :KEY #'LALR-ACTION-CATEGORIES
                                    :TEST #'MEMBER))
                 (SETF CUR-STATE (SHIFT-ACTION-GOTO ACTION))
                 (GO :DISPATCH)))
              (T
               (error "parse error~%LA = ~S~%STATE = ~S~%" CAT CUR-STATE)) ))))


;;;; -- TOOD ----------------------------------------------------------------------------------

;; - Either allow for arbitrary lexemes (including strings) or have some hook
;;   for spelling a lexeme.

;; - Precedence for an operator alone is not enough. They at times are heavily
;;   overloaded. So we would need means to specify the precedence of a given
;;   token. Something like:

;;    (expr -> expr (:left "+") expr)

;; This implies that precedence is not per token, but per mentioning of a token.

;; Also: Switch GRAMMAR-STATE-TABLE to accepting something more like:

;; (<name> ( { <name> }* ) <action>)

;; What I'd rather have is a function taking:

;; rules -- a list of (<cat> ( { <daughter> }* ) <action>)

;; returning a table as mapped out above.

;; Surface syntax, conflict resolution, and driver needs to happen outside.

;; We would need some means to have local precedence. Maybe:

;; (expr -> expr (:left "+") expr)

;; It must be possible to apply a precedence to an individual token.

;; Like stmt -> "if" expr "then" stmt (:left "else") stmt

;; Borrow from Prolog? expr -> expr (:yfx "+") expr

;; Maybe we pull this as RULE-OPTIONS = (:prec 1 :left 100)
;; RULE-PRECEDENCES -> ((1 :left 100))
;;
;; expr -> expr (:left) "+" expr
;; expr -> "if" expr "then" expr (:nonassoc) "then" expr
;; 

;; Anyhow, we _need_ means to have rhs being some data object.

;; -


;;;; ------------------------------------------------------------------------------------------

#+(or)
(defun lalr-table-3 (rules lexemes end-marker)
  (setq *end-marker* end-marker)
  (setq *precedence* nil)
  (setq *lex* nil)
  (setq *lex-spelling* (make-hash-table))
  (dolist (k lexemes)
    (if (consp k)
        (destructuring-bind (kw spelling) k
          (push kw *lex*)
          (setf (gethash kw *lex-spelling*) spelling))
        (push k *lex*)))
  ;; cache some data that will be useful later
  (setq *lex-vector* (coerce (cons *end-marker* *lex*) 'vector))
  (setq *lex-index* (make-hash-table :test 'eq))
  (loop for j from 0 for c across *lex-vector* do (setf (gethash c *lex-index*) j))
  (setq *start* (caar rules))
  (setq *rules* (let ((i 0))
                  (mapcar (lambda (r) (make-rule :no (1- (incf i)) :mother (car r) :daughters (cdr r)))
                          rules)))
  (setq *nrules* (length *rules*))
  (setq *cats* (get-all-cats *start*))
  (setq *expansions* (make-hash-table :test 'eq))
  (dolist (cat *cats*)
    (setf (gethash cat *expansions*) (compute-expansion cat)))
  (setq *epsilons* (remove-if-not #'derives-eps *cats*))
  (setq *starts* (make-hash-table :test 'eq))
  (dolist (cat (cons *end-marker* *cats*))
    (setf (gethash cat *starts*) (first-terms (list cat))))
  ;; now actually build the parser
  (build-table *start*)
  (when (and (listp *lalr-debug*) (member 'print-table *lalr-debug*))
    (print-table *state-list*))
  (format t "~&Table ready, ~D rules, ~D states, ~D terminals.~%"
          *nrules* (length *state-list*) (length *lex*))
  (force-output)
  (setq *state-list* (compute-reduces *state-list*))
  '(setq *state-list* (resolve-conflicts *state-list*))
  *state-list*)

;; We could state that each rule has a precedence and and optionally an
;; associativity. A conflict is between two rules. If rules have different
;; precedence the rule with the higher precedence reduces, the other shifts.
;; If both rules have the same precedence then the associativity says whether
;; we shift or reduce.




;; Some reduces are harmless for they return the same value.

#+NIL
;; Why not?
(defclass production ()
  ((lhs :initarg :lhs :initform nil :accessor production-lhs)
   (rhs :initarg :rhs :initform nil :accessor production-rhs)
   (action :initarg :action :initform nil :accessor production-action)
   (plist :initarg :plist :initform nil :accessor production-plist)))