;;; Bibliography
;;; [1] 佐々政孝: 「プログラミング言語処理系」, 岩波書店(1989)
(define-module util.lalr
  (use srfi-1)
  (use srfi-11)
  (use srfi-43)
  (use gauche.sequence)
  (use util.match)
  (use util.set)
  (use missing.collection)
  (use missing.sequence)
  (export <lr-parser>
	  lr-parse
	  lalr-grammar
	  make-lr1-parser
	  make-lalr1-parser
	  op-spec->precedence-table
	  lr1-parser->lalr1-parser))

(select-module util.lalr)

(define-macro (lalr-grammar term-defs . non-term-defs)
  (define (expand-non-term-def non-term-def)
    (let1 head (car non-term-def)
      (map (lambda (clause)
	     (receive (r-rule-body r-arg)
		 (fold2 (lambda (sym rule arg)
			  (cond ((#/@/ (symbol->string sym))
				 => (lambda (m)
				      (values
				       (cons (string->symbol (m 'before)) rule)
				       (cons (string->symbol (m 'after)) arg))))
				(else
				 (values (cons sym rule) (cons sym arg)))))
			'() '() (car clause))
	       (cons `#(,head ,@(reverse! r-rule-body))
		     (list 'unquote `(lambda ,(reverse! r-arg) ,@(cdr clause))))))
	   (cdr non-term-def))))
  `(receive (f g) (op-spec->precedence-table ',term-defs)
     (make-lalr1-parser
      ',(append-map (lambda (def)
		      (if (pair? def) (cdr def) (list def)))
		    term-defs)
      ,(list 'quasiquote
	     (append-map expand-non-term-def non-term-defs))
      f g)))

(define (op-spec->precedence-table specs)
  (let1 table (concatenate!
	       (map-with-index
		(match-lambda*
		 ((i (type . ops))
		  (map (case type
			 ((unary) (cute list <> (* 2 i) 1/0))
			 ((left)  (cute list <> (+ (* 2 i) 1) (* 2 i)))
			 ((right) (cute list <> (* 2 i) (+ (* 2 i) 1))))
		       ops))
		 (_ '()))
		(reverse specs)))
    (values (lambda (sym)
	      (cond ((assq sym table) => second)
		    (else #f)))
	    (lambda (sym)
	      (cond ((assq sym table) => third)
		    (else #f))))))


(define-class <lr-parser> ()
  ((initial-state
    :init-keyword :initial-state
    :getter initial-state-of)
   (action-table
    :init-keyword :action-table
    :getter action-table-of)
   (goto-table
    :init-keyword :goto-table
    :getter goto-table-of)
   (f
    :init-keyword :left-precedence-function
    :getter left-precedence-function-of)
   (g
    :init-keyword :right-precedence-function
    :getter right-precedence-function-of)))

(define (rule-head rule)
  (ref (rule-body rule) 0))
(define rule-body car)
(define rule-reducer cdr)
(define (rule-length rule)
  (size-of (rule-body rule)))

(define (lr-parse parser lexer)
  (let ((action-table (action-table-of parser))
	(goto-table (goto-table-of parser))
	(init (initial-state-of parser))
	(f (left-precedence-function-of parser))
	(g (right-precedence-function-of parser)))
    (let loop ((input (lexer))
	       (state init)
	       (state-stack (list init))
	       (value-stack '()))
      (receive (sym val) (car+cdr input)
	(let dispatch ((action (ref action-table (cons state sym) #f)))
	  (match action
	    ('accept (car value-stack))
	    (('or [and shift-op ('shift . _)]
		  [and reduce-op ('reduce . _)])
	     (or (and-let* (((not (null? value-stack)))
			    ((pair? (cdr value-stack)))
			    (a (f (second value-stack)))
			    (b (g sym)))
		   (dispatch (if (<= a b) shift-op reduce-op)))
		 (errorf "shift/reduce conflict: ~A on~%~A"
			 val state)))
	    (('reduce . (t i proc))
	     (let*-values (((ss) (drop state-stack i))
			   ((args vals) (split-at! value-stack i))
			   ((ns) (ref goto-table (cons (car ss) t))))
	       (loop input ns (cons ns ss)
		     (cons (apply proc (reverse! args)) vals))))
	    (('shift . s)
	     (loop (lexer) s (cons s state-stack) (cons val value-stack)))
	    (_ (errorf "parse error: ~A on~%~A"
		       input state))))))))

(define (memoise fn)
  (let1 tbl (make-hash-table 'equal?)
    (lambda args
      (if (hash-table-exists? tbl args)
	  (hash-table-get tbl args)
	  (let1 res (apply fn args)
	    (hash-table-put! tbl args res)
	    res)))))

;;; [1] pp.191-196
(define (make-lr1-parser terminals rls f g)
  (let* ((non-terminals (delete-duplicates! (map rule-head rls) eq?))
	 (syms (append terminals non-terminals))
	 (init-sym (gensym))
	 (initial-symbol? (cute eq? <> init-sym))
	 (non-terminal? (cute memq <> non-terminals))
	 (terminal? (complement non-terminal?))
	 (init-rule `(#(,init-sym ,(rule-head (ref rls 0))) . ,values))
	 (rules (list->vector (cons init-rule rls))))
    (define make-lr1-item vector)
    (define lr1-item-rule-num (cute vector-ref <> 0))
    (define lr1-item-current-pos (cute vector-ref <> 1))
    (define lr1-item-lookahead (cut vector-ref <> 2))
    (define (lr1-item-rule item)
      (rule-body (vector-ref rules (lr1-item-rule-num item))))
    (define (lr1-item-head item)
      (vector-ref (lr1-item-rule item) 0))
    (define (lr1-item-current-sym item)
      (and (lr1-item-more-syms? item)
	   (vector-ref (lr1-item-rule item) (lr1-item-current-pos item))))
    (define (lr1-item-next-sym item)
      (and (< (+ (lr1-item-current-pos item) 1)
	      (size-of (lr1-item-rule item)))
	   (vector-ref (lr1-item-rule item) (+ (lr1-item-current-pos item) 1))))
    (define (lr1-item-more-syms? item)
      (< (lr1-item-current-pos item)
	 (size-of (lr1-item-rule item))))
    (define (lr1-item-rest-syms item)
      (if (not (lr1-item-more-syms? item))
	  '()
	  (list-tail (vector->list (lr1-item-rule item))
		     (+ 1 (lr1-item-current-pos item)))))
    (define (lr1-item-reducer item)
      (rule-reducer (vector-ref rules (lr1-item-rule-num item))))
    (define lr1-goto
      (memoise
       (lambda (items sym)
	 (lr1-closure
	  (list->set 'equal?
	   (filter-map (lambda (item)
			 (and-let* ((s (lr1-item-current-sym item))
				    ((eq? s sym)))
			   (make-lr1-item (lr1-item-rule-num item)
					  (+ 1 (lr1-item-current-pos item))
					  (lr1-item-lookahead item))))
		       items))))))
    (define lr1-closure
      (memoise
       (lambda (items)
	 (define (first-syms syms)
	   (define first-syms/aux
	     (memoise
	      (lambda (sym)
		(if (terminal? sym)
		    (list sym)
		    (concatenate!
		     (filter-map
		      (lambda (rule)
			(and (eq? sym (rule-head rule))
			     (if (= (rule-length rule) 1)
				 '(())
				 (let1 bs (coerce-to <list> (rule-body rule))
				   (and (not (eq? (car bs) sym))
					(first-syms (cdr bs)))))))
		      rules))))))
	   (let loop ((syms syms) (res '()) (eps? #t))
	     (if (or (not eps?) (null? syms))
		 res
		 (let1 rs (first-syms/aux (car syms))
		   (loop (delete (car syms) (cdr syms) eq?)
			 (append (remove null? rs) res)
			 (and (find null? rs) #t))))))
	 (define (closure-for item)
	   (and-let* ((sym (lr1-item-current-sym item))
		      ((non-terminal? sym)))
	     (list->set
	      'equal?
	      (filter-map-with-index
	       (lambda (idx rule)
		 (and (eq? (rule-head rule) sym)
		      (make-lr1-item
		       idx 1
		       (or (and-let* ((s (lr1-item-next-sym item))
				      ((terminal? s)))
			     (list s))
			   (append-map (lambda (a)
					 (first-syms
					  (append (lr1-item-rest-syms item)
						  (list a))))
				       (lr1-item-lookahead item))))))
	       rules))))
	 (let loop ((rs items) (prevs items))
	   (let1 is ((cut set-difference <> rs)
		     (apply set-union (filter-map closure-for prevs)))
	     (if (empty? is)
		 rs
		 (loop (set-union rs is) is)))))))
    (define (canonical-lr1-collection)
      (let* ((init-state (lr1-closure
			  (set 'equal? (make-lr1-item 0 1 (list #t)))))
	     (init (set 'equal? init-state)))
	(let collect ((rs init) (prevs init))
	  (let1 items ((cut set-difference <> rs)
		       (set-union-map
			(lambda (sym)
			  (list->set 'equal?
				     (map (lambda (item)
					    (lr1-goto item sym))
					  prevs)))
			syms))
	    (if (empty? items)
		(values init-state (remove null? rs))
		(collect (set-union! rs items) items))))))
    (let ((action-table (make-hash-table 'equal?))
	  (goto-table (make-hash-table 'equal?)))
      (define (next-terminal item)
	(and-let* ((sym (lr1-item-current-sym item))
		   ((terminal? sym)))
	  sym))
      (define (reducible? item)
	(not (lr1-item-more-syms? item)))
      (define (add-action/goto-entry! items)
	(define (step2-1 term-sym)
	  (let ((state (lr1-goto items term-sym))
		(key (cons items term-sym)))
	    (set! (ref action-table key) `(shift . ,state))))
	(define (step2-2 item)
	  (define (conflict-error entry action trigger items)
	    (let1 type (case (car entry)
			 ((shift) 'shift)
			 (else 'reduce)) 
	      (errorf "~A/reduce conflict:~%~A or ~A with ~A~%on~%~A"
		      type entry action trigger items)))
	  (for-each
	   (lambda (trigger)
	     (let ((key (cons items trigger))
		   (action `(reduce ,(lr1-item-head item)
				    ,(- (lr1-item-current-pos item) 1)
				    ,(lr1-item-reducer item))))
	       (cond ((ref action-table key #f)
		      => (lambda (entry)
			   (or (when (eq? (car entry) 'shift)
				 (set! (ref action-table key)
				       `(or ,entry ,action))
				 #t)
			       (conflict-error entry action trigger items))))
		     (else
		      (set! (ref action-table key) action)))))
	   (lr1-item-lookahead item)))
	(define (step2-3 is)
	  (when (find (lambda (item)
			(and (initial-symbol? (lr1-item-head item))
			     (reducible? item)
			     (memq #t (lr1-item-lookahead item))))
		      is)
	    (set! (ref action-table (cons is #t)) 'accept)))
	(define (step3 non-term-sym)
	  (let1 state (lr1-goto items non-term-sym)
	    (unless (null? state)
	      (set! (ref goto-table (cons items non-term-sym)) state))))
	(for-each step2-1 (delete-duplicates! (filter-map next-terminal items) eq?))
	(for-each step2-2 (filter reducible? items))
	(step2-3 items)
	(for-each step3 non-terminals))
      (receive (initial states) (canonical-lr1-collection)
	(for-each add-action/goto-entry! states)
	(make <lr-parser>
	  :initial-state initial
	  :action-table action-table
	  :goto-table goto-table
	  :left-precedence-function f
	  :right-precedence-function g)))))

(define (make-lalr1-parser terminals rules f g)
  (lr1-parser->lalr1-parser (make-lr1-parser terminals rules f g)))

(define (lr1-parser->lalr1-parser lr1-parser)
  (let* ((lr1-at (action-table-of lr1-parser))
	 (lr1-gt (goto-table-of lr1-parser))
	 (core (group-collection (delete-duplicates
				  (map car (hash-table-keys lr1-at)))
				 :key (lambda (se)
					(map (lambda (i)
					       (list
						(vector-ref i 0)
						(vector-ref i 1)))
					     se))
				 :test (cut lset= equal? <> <>))))
    (let1 lr1->lalr1-table (make-hash-table 'eq?)
      (for-each
       (lambda (states)
	 (for-each
	  (cut hash-table-put! lr1->lalr1-table <> (apply set-union states))
	  states))
       core)
      (let ((lalr1-at (make-hash-table 'equal?))
	    (lalr1-gt (make-hash-table 'equal?)))
	(hash-table-for-each lr1-at
	  (lambda (st&input act)
	    (let ((lalr1-state (ref lr1->lalr1-table (car st&input)))
		  (input (cdr st&input)))
	      (set! (ref lalr1-at (cons lalr1-state input))
		    (match act
		      ([or 'accept ('reduce . _)] act)
		      (('shift . state)
		       `(shift ,@(ref lr1->lalr1-table state)))
		      (('or ('shift . state)
			    [and reduce-op ('reduce . _)])
		       `(or (shift ,@(ref lr1->lalr1-table state))
			    ,reduce-op)))))))
	(hash-table-for-each lr1-gt
	  (lambda (s1&input s2)
	    (let ((lalr1-state (ref lr1->lalr1-table (car s1&input)))
		  (input (cdr s1&input)))
	      (set! (ref lalr1-gt (cons lalr1-state input))
		    (ref lr1->lalr1-table s2)))))
	(make <lr-parser>
	  :initial-state (ref lr1->lalr1-table (initial-state-of lr1-parser))
	  :action-table lalr1-at
	  :goto-table lalr1-gt
	  :left-precedence-function (left-precedence-function-of lr1-parser)
	  :right-precedence-function (right-precedence-function-of lr1-parser))))))

(provide "util/lalr")