#+(or)
(defpackage :de.bauhh.define-grammar
  (:use :cl :de.bauhh.lalr)
  (:shadow #:define-grammar))

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

(in-package :nyala)


;;;; Overview

;; This is surface syntax to interface to lalr.cl.

;;   grammar := { rule }*
;;      rule := ( category { -> rhs }+ )
;;            | option
;;       rhs := { pattern }* [ => action ]
;;   pattern := category
;;            | token
;;            | (? rhs)
;;            | (+ rhs)
;;            | (** token rhs)
;;            | (++ token rhs)
;;   category := a symbol, but not a keyword
;;      token := a keyword or a string
;;     action := a Lisp form
;;     option := (:PRECEDENCE { precedence }*)
;; precedence := ({ :LEFT | :RIGHT | :NONASSOC } { token }*)

;; Within an action symbols named $i ($1, $2, ..) refer to the ith
;; semantic action. The package of those symbols is not important, but
;; those symbols must appear lexically within the action.

;; As with LOOP the symbols -> and => are compared with STRING=.


;;;; TODO

;; Perhaps we want sth like
;;
;;     (LALR-TABLE
;;        (top -> foos)
;;        (foo -> foos foo
;;                foo))
;;
;; 


;;;;

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

(defstruct (fancy-lalr-table (:include lalr-table))
  terminals)

(defvar *intern-keyword*
  (lambda (string)
    (intern (string-upcase string) :keyword))
  "Function used to actually intern keywords given as strings in the grammar.")

(defvar *conflict-resolver*
  nil
  "If set, a function that resolves conflicts in a set of items")

(defun compile-define-grammar-1 (rules)
  ;; This compiles a grammar to
  ;;  - an lalr table
  ;;  - an alist of (<cat> . <text>) of the tokens found
  ;;  - a list of action lambdas
  ;;
  ;; The REDUCE-ACTION-FUNCTION contain an index into that list of actions.
  ;;
  ;; We need this indirect reference because a grammar may be burried
  ;; inside some other lexical environment.
  ;;
  (multiple-value-bind (rules tokens options)
      (edit-grammar rules)
    ;; tokens is an alist of token keywords mapping to the spelling, if any
    (check-usage rules tokens)
    (let* ((defined     (remove-duplicates (mapcar #'car rules)))
           (used        (remove-duplicates (cons (caar rules) (mapcan #'copy-list (mapcar #'cadr rules)))))
           ;; (undef       (remove-if (lambda (x) (or (assoc x tokens) (member x defined))) used))
           ;; (unused      (set-difference defined used))
           (terminals   (set-difference used defined)))
      ;; (when undef (warn "Undefined: ~S" undef))
      ;; (when unused (warn "Unused non-terminals: ~S" unused))
      (let ((aux-funs 
             ;; A list of lambda expressions.
             nil))
        ;; All rule lambdas are gathers into aux-funs and the rule lambda is
        ;; replaced by the index of that new aux-fun.
        (setq rules (mapcar (lambda (rule)
                              (destructuring-bind (lhs rhs lambda-form options) rule
                                (let ((lambda-form
                                       (etypecase lambda-form
                                         ((cons (member LAMBDA) t) lambda-form)
                                         ((cons (member FUNCTION)
                                                (cons (cons (member LAMBDA) t)
                                                      null))
                                          (cadr lambda-form)))))
                                  (let ((i (position lambda-form aux-funs :test 'equal)))
                                    (unless i
                                      (setq i (length aux-funs))
                                      (setq aux-funs (nconc aux-funs (list lambda-form))))
                                    ;; (format t "#~D = ~S~%" i lambda-form)
                                    ;; (push lambda-form aux-funs)
                                    ;; (list lhs rhs (1- (length aux-funs)) options)
                                    (list lhs rhs i options)))))
                            rules))
        ;; (setq aux-funs (reverse aux-funs))
        ;;
        (let ((lalr-table
               (grammar-lalr-table
                (mapcar (lambda (x)
                          (let ((spelling (cdr (assoc x tokens))))
                            (if spelling (list x spelling) x)))
                        terminals)
                `(,@options ,@rules))))
          ;; Copy it to a fancy table, which is the same as an lalr table but the tokens
          (setq lalr-table (make-fancy-lalr-table
                            :topcat (lalr-table-topcat lalr-table)
                            :states (lalr-table-states lalr-table)
                            :terminals tokens))
          ;; Done.
          (values lalr-table tokens aux-funs))))))

(defun check-usage (rules tokens)
  (let (reached)
    ;; For usage we need to traverse the grammar from the topcat and collect
    ;; all non-terminals that are reached.
    (labels ((walk (cat)
               (unless (member cat reached)
                 (push cat reached)
                 (mapcar (lambda (r)
                           (mapc #'walk (cadr r)))
                         (remove cat rules :key 'car :test-not 'eq)))))
      (walk (caar rules))
      (let* ((defined (remove-duplicates (mapcar #'car rules)))
             (unused (set-difference defined (reverse reached)))
             (undefined (set-difference (set-difference reached defined) (mapcar 'car tokens))))
        (when unused
          (warn "Unused non-terminals: ~<~@{~S~^, ~:_~}~:>" unused))
        (when undefined
          (warn "Undefined categories: ~<~@{~S~^, ~:_~}~:>" undefined))))))



(defmethod make-load-form ((object lalr-table) &optional environment)
  (declare (ignore environment))
  `(cons-lalr-table :topcat ',(lalr-table-topcat object)
                    :states ',(lalr-table-states object)))

(defmethod make-load-form ((object fancy-lalr-table) &optional environment)
  (declare (ignore environment))
  `(make-fancy-lalr-table :topcat ',(lalr-table-topcat object)
                          :states ',(lalr-table-states object)
                          :terminals ',(fancy-lalr-table-terminals object)))

(defmethod make-load-form ((object lalr-state) &optional environment)
  (declare (ignore environment))
  `(make-lalr-state :name ',(lalr-state-name object)
                    :transitions ',(lalr-state-transitions object)))

(defmethod make-load-form ((object shift-action) &optional environment)
  (declare (ignore environment))
  `(make-shift-action :categories ',(lalr-action-categories object)
                      :goto ',(lalr-action-goto object)))

(defmethod make-load-form ((object reduce-action) &optional environment)
  (declare (ignore environment))
  `(make-reduce-action :categories ',(lalr-action-categories object)
                       :goto ',(lalr-action-goto object)
                       :npop ',(reduce-action-npop object)
                       :function ',(reduce-action-function object)))


;;;;

;; Modify this to intern tokens first to allow for (:ANY-TOKEN-BUT ...).
;; We can either collect tokens before expanding iteration, or after.

(defun edit-grammar (rules)
  ;; Returns three values
  ;; rules -- a list of (lhs rhs action-lambda options)
  ;;          lhs is a category, rhs is a list of categories, lambda-form is
  ;;          a lambda taking all the semantic values of the rhs items,
  ;;          options is a list of rule options.
  ;; tokens -- an alist of category symbols and their spelling (string) if any.
  ;; grammar-options -- a list of grammar options
  ;; 
  (let* ((queue nil) ;A queue of rules in (lhs -> rhs ..) form to process
         (bag nil)   ;Result list as (lhs rhs-list action-lambda)
         (taken-names nil) ;A list of all non-terminal names already present
         (user-tokens nil)
         (rules (remove-if (lambda (r)
                             (cond ((and (consp r) (member (car r) '(:tokens :token)))
                                    (setq user-tokens (append user-tokens (cdr r)))
                                    t)))
                           rules))
         (grammar-options (remove-if-not #'keywordp rules :key 'car))
         (rules   (remove-if #'keywordp rules :key 'car))
         ;; Memorizes rhs items, so that we have only one rule for multiple e.g. (? foo)'s
         (memo    (make-hash-table :test #'equal))
         (tokens  nil)                 ;A-list of token keywords
         ($n-symbols nil))             ;A-list for GEN-$N
    (labels ((edit-rule (rule)
               (compiler-descend rule
                 (loop for (lhs rhs . actions) in (reverse (parse-rule rule)) do
                       (edit-rule-1 lhs rhs actions))))
             ;;
             (edit-rule-1 (lhs rhs actions)
               ;; Strip the rule options right away
               (multiple-value-bind (rhs rule-options)
                   (values (remove-if #'rule-option-p rhs)
                           (remove-if-not #'rule-option-p rhs))
                 (unless actions
                   (setq actions (list (rule-default-action lhs rhs))))
                 (edit-rhs-items lhs rhs actions
                                 1 (form-all-$n-symbol-map actions)
                                 nil nil nil
                                 rule-options)))
             ;;
             (rule-option-p (x)
               (typep x '(cons (member :prec :left :right :nonassoc))))
             ;;
             (gen-$n (n)
               (cdr (or (assoc n $n-symbols)
                        (car (push (cons n (make-symbol (format nil "$~D" n))) $n-symbols)))))
             ;;
             (edit-rhs-items (rule-name items body n map yet ps bs rule-options)
               ;;
               ;; _rule-name_ is the name of the overall rule (its lhs)
               ;; _items_ is the tail of remaining rhs items
               ;; _body_ is the body of the rule.
               ;; _n_ counts up and is the (one-based) position in the rhs
               ;; _map_ is a map of rule positions to a list of user variables
               ;;
               ;; This routine gets the accumulated new rule in form of:
               ;;
               ;; _yet_ is the newly constructed rhs
               ;;
               ;; _ps_ is the newly constructed list of the parameters of the rule lambda
               ;;
               ;; _bs_ is a list of (<user-var> <form>) bindings for the rule lambda, the <form>
               ;;      usually is a parameter but could also be any form. E.g. NIL for (? ..) or
               ;;      (REVERSE ..) for lists.
               ;;
               ;; _rule-options_ is a list of rule options. atm this is only a rule precedence
               ;;      like (:prec n)
               ;;
               ;; And finally pushes the resulting rule as (<lhs> <rhs-list> <lambda>) onto _bag_.
               ;;
               ;; Anything that can derive epsilon like (? ..) or (* ..) is implemented by
               ;; copying the rule, if needed. Once with the optional item, once w/o. This is
               ;; because otherwise adjacent optional item would result into conflicts.
               ;;
               (cond ((null items)
                      ;; We have a whole rule
                      (yield-rule rule-name yet 
                                  `(lambda ,ps
                                     (declare (ignorable ,@ps))
                                     (symbol-macrolet ,bs
                                       ,@body))
                                  rule-options))
                     (t
                      (destructuring-bind (item &rest more) items
                        (labels ((yield (new)
                                   (let ((p (gen-$n n)))
                                     (edit-rhs-items rule-name more body (1+ n) map
                                                     (append yet (list new))
                                                     (append ps (list p))
                                                     (append bs (mapcar (lambda (v) (list v p))
                                                                        (cdr (assoc n map))))
                                                     rule-options))))
                          (cond ((keywordp item) (yield (intern-token item)))
                                ((symbolp item) (yield item)) 
                                ((stringp item) (yield (intern-token item)))
                                ((and (consp item) (symbol= (car item) '?))
                                 (edit-rhs-items rule-name (cons `(AND ,@(cdr item)) more) body
                                                 n map
                                                 yet ps bs rule-options)
                                 (edit-rhs-items rule-name more body
                                                 (1+ n) map yet
                                                 ps
                                                 (append bs (mapcar (lambda (v) (list v 'NIL))
                                                                    (cdr (assoc n map))))
                                                 rule-options))
                                ((and (consp item) (symbol= (car item) 'or))
                                 (dolist (k (cdr item))
                                   (edit-rhs-items rule-name (cons k more) body
                                                   n map
                                                   yet ps bs
                                                   rule-options)))
                                ((and (consp item) (symbol= (car item) 'and))
                                 (multiple-value-bind (item-rhs item-action-body)
                                     (parse-item-macro item (cdr item))
                                   (cond ((and (null item-action-body)
                                               (= 1 (length item-rhs)))
                                          (edit-rhs-items rule-name (cons (car item-rhs) more) body
                                                          n map
                                                          yet ps bs
                                                          rule-options))
                                         (t
                                          (let ((aux-name
                                                 (or (gethash item memo)
                                                     (setf (gethash item memo)
                                                           (let ((aux-name (gen-name rule-name 'aux)))
                                                             (edit-rule-1 aux-name item-rhs item-action-body)
                                                             aux-name)))))
                                            (edit-rhs-items rule-name (cons aux-name more) body
                                                            n map
                                                            yet ps bs
                                                            rule-options))))))
                                ;;
                                ((and (consp item) (symbol= (car item) '+))
                                 (let ((aux-name (or (gethash item memo)
                                                     (setf (gethash item memo)
                                                           (let ((aux-name (gen-name-2 rule-name (cdr item) 'list)))
                                                             (edit-rule-1 aux-name (list `(and ,@(cdr item))) '((LIST $1)))
                                                             (edit-rule-1 aux-name (list aux-name `(and ,@(cdr item))) '((CONS $2 $1)))
                                                             aux-name)))))
                                   (let ((p (gen-$n n)))
                                     (edit-rhs-items rule-name more body
                                                     (1+ n) map
                                                     (append yet (list aux-name))
                                                     (append ps (list p))
                                                     (append bs (mapcar (lambda (v) (list v `(reverse ,p)))
                                                                        (cdr (assoc n map))))
                                                     rule-options))))
                                ;;
                                ((and (consp item) (symbol= (car item) '++))
                                 (let ((aux-name (or (gethash item memo)
                                                     (setf (gethash item memo)
                                                           (let ((aux-name (gen-name-2 rule-name (cddr item) 'list)))
                                                             (edit-rule-1 aux-name (list `(and ,@(cddr item))) '((LIST $1)))
                                                             (edit-rule-1 aux-name (list aux-name (cadr item) `(and ,@(cddr item))) '((CONS $3 $1)))
                                                             aux-name)))))
                                   (let ((p (gen-$n n)))
                                     (edit-rhs-items rule-name more body
                                                     (1+ n) map
                                                     (append yet (list aux-name))
                                                     (append ps (list p))
                                                     (append bs (mapcar (lambda (v) (list v `(reverse ,p)))
                                                                        (cdr (assoc n map))))
                                                     rule-options))))
                                ;;
                                ((and (consp item) (symbol= (car item) '*))
                                 (edit-rhs-items rule-name (cons `(? (+ ,@(cdr item))) (cdr items)) body n map yet ps bs rule-options))
                                ;;
                                ((and (consp item) (symbol= (car item) '**))
                                 (edit-rhs-items rule-name (cons `(? (++ ,@(cdr item))) (cdr items)) body n map yet ps bs rule-options))
                                ;;
                                (t
                                 (compiler-warn item "Bad rhs item - ~S" item))))))))
             ;;
             (yield-rule (lhs rhs action rule-options)
               (push (list lhs rhs action rule-options) bag))
             ;;
             (parse-item-macro (whole args)
               (when (or (> (count '=> args :test #'symbol=) 1)
                         (> (count '-> args :test #'symbol=) 0))
                 (error "Malformed item: ~S" whole))
               (let* ((q (member '=> args :test #'symbol=))
                      (rhs (ldiff args q))
                      (actions (cdr q)))
                 (values rhs actions)))                 
             ;;
             (gen-name (prefix suffix)
               (do* ((i 0 (+ i 1))
                     (s (format nil "~A-~A" prefix suffix)
                        (format nil "~A-~A-~D" prefix suffix i)))
                    ((or (null (find-symbol s)) (not (member (intern s) taken-names)))
                     (setq s (intern s))
                     (pushnew s taken-names)
                     s)))
             ;;
             (gen-name-2 (rule-name item-rhs suffix)
               (gen-name (or (and item-rhs (symbolp (car item-rhs)) (car item-rhs))
                             (format nil "~A-AUX" rule-name))
                         suffix))
             ;;
             (intern-token (tok)
               (cond ((or (symbolp tok) #+NIL (stringp tok))
                      (pushnew (list tok) tokens :key #'car :test #'equal)
                      tok)
                     ((stringp tok)
                      (let* ((s (funcall *intern-keyword* tok))
                             (q (assoc s tokens :test #'equal)))
                        (cond (q (unless (equal (cdr q) tok)
                                   (error "Oops, different spelling found. ~S vs ~S" tok (cdr q))))
                              (t (push (cons s tok) tokens)))
                        s))
                     (t (error "Odd token: ~S" tok)))) )
      ;;
      (setq queue (reverse rules))
      (mapc #'intern-token user-tokens)
      (dolist (k queue) (pushnew (car k) taken-names))
      (do () ((null queue)) (edit-rule (pop queue)))
      ;;
      (values
       bag
       tokens
       (mapcar (lambda (option)
                 (destructuring-bind (key &rest more) option
                   (cond #+NIL
                         ((eq :tokens key)
                          (cons key (mapcar #'intern-token more)))
                         ((eq :precedence key)
                          (cons key (mapcar (lambda (q)
                                              (cons (car q) (mapcar #'intern-token (cdr q))))
                                            more)))
                         ((and (keywordp key) (symbol= (car more) '->))
                          (intern-token key)
                          option)
                         (t option))))
               grammar-options)))))

(defun parse-rule (rule &aux res)
  ;; Takes a rule in (<lhs> { -> <rhs> [ => <action> ] }*) form and returns
  ;; a list of (<lhs> <rhs> . <body>)
  (labels ((blame (p what)
             (declare (ignore p))
             (compiler-error
              rule
              "~@<Bad rule: ~S; ~_~A~:>" rule what)))
    (let ((p (position '-> rule :test #'symbol=)))
      (unless p (blame p "Missing ->"))
      (unless (and (eql p 1) (symbolp (car rule)))
        (blame p "Left hand side before first -> must be exactly one symbol."))
      (let ((name (car rule)) (p1 p) p2)
        (loop
          (setq p2 (position '-> rule :test #'symbol= :start (1+ p1)))
          (let ((p3 (position '=> rule :test #'symbol= :start (1+ p1) :end p2)))
            (push (list* name
                        (subseq rule (1+ p1) (or p3 p2))
                        (and p3 (subseq rule (1+ p3) p2))) res))
          (unless p2 (return))
          (setq p1 p2))
        (reverse res)))))

(defun symbol= (sym what)
  (and (symbolp sym) (not (keywordp sym))
       (symbolp what) (not (keywordp what))
       (string= sym what)))

(defun rule-default-action (lhs rhs)
  ;; (declare (ignore lhs))
  (block nil
    (when (= 0 (length rhs)) nil)
    (when (= 1 (length rhs)) (return '$1))
    (ignore-errors
      (destructuring-bind (lhs op rhs) rhs
        (declare (ignore lhs rhs))
        (when (and (or (stringp op) (keywordp op)))
          (return `(list ',(intern (string-upcase (string op))) $1 $3)))))
    (ignore-errors
      (destructuring-bind (op rhs) rhs
        (declare (ignore rhs))
        (when (and (or (stringp op) (keywordp op)))
          (return `(list ',(intern (string-upcase (string op))) $2)))))
    (when (null rhs)
      (return ''nil))
    (cons 'list
          (cons `',lhs
                (loop for i from 1 to (length rhs)
                      collect (intern (format nil "$~D" i)))))))


;;;; Borrowed from CLEX

(defun form-all-$n-symbol-map (form &aux res)
  "Returns an alist mapping integers `n' to all symbols named `$n' in the
s-expression `form'. For ease, we map `$$' as n=0."
  (loop for sym in (all-symbols-in-form form)
        for n = ($n-symbol-p sym) do
        (when n
          (pushnew sym (cdr (or (assoc n res)
                                (car (push (list n) res)))))))
  res)

(defun $n-symbol-p (symbol)
  "Does the symbol `symbol` have a name like $<n>, <n> some positive
integer? Returns that `n' or NIL."
  (and (symbolp symbol)
       (not (keywordp symbol))
       (let ((name (string symbol)))
         (cond ((and (> (length name) 1)
                     (char= #\$ (char name 0))
                     (char/= #\0 (char name 1))
                     (every #'digit-char-p (subseq name 1)))
                (parse-integer name :start 1))
               ((string= symbol "$$")
                0)))))

#+SBCL
(defun all-symbols-in-form (form &aux res (orig *print-pprint-dispatch*))
  "Collect all symbols in the s-expression `form'. Glorious hack needed
because of SBCL. Thanks."
  (handler-bind
      ((error (lambda (cond)
                (let ((*print-pprint-dispatch* orig))
                  (error cond)))))
    (with-standard-io-syntax 
      (let ((default-table (copy-pprint-dispatch nil))
            (*print-pprint-dispatch* (copy-pprint-dispatch nil))
            (*print-pretty* t)
            (*print-circle* t))
        (set-pprint-dispatch 't (lambda (stream object)
                                  (if (symbolp object)
                                      (pushnew object res)
                                      (funcall (pprint-dispatch object default-table) stream object))))
        (pprint form (make-broadcast-stream))
        res))))

#-SBCL
(defun all-symbols-in-form (form &aux res)
  "Sane version for sane Lisps."
  (labels ((walk (x)
             (cond ((symbolp x) (pushnew x res))
                   ((atom x))
                   (t
                    (walk (car x))
                    (walk (cdr x))))))
    (walk form)
    res))


#+(or)
(progn
  (set-pprint-dispatch '(cons symbol (cons (member ->) t))
                       'print-rule)
  (defun print-rule (stream object)
    (pprint-logical-block (stream object :prefix "(" :suffix ")")
      (loop
        (pprint-exit-if-list-exhausted)
        (let ((x (pprint-pop)))
          (cond ((or (symbol= x '->)
                     (symbol= x '=>))
                 (pprint-newline :mandatory stream)
                 (prin1 x stream)
                 (write-char #\space stream))
                (t
                 (prin1 x stream)
                 (write-char #\space stream))))))))