;;;; argot.lisp

(in-package #:argot)


(define-condition invalid-rule-def (error)
  ((rule :reader rule :initarg :rule))
  (:report (lambda (e stream)
             (format stream "The rule ~s is malformed." (car (rule e))))))

(defun nonterminal? (lhs)
  (and (symbolp lhs)
       (let* ((name (symbol-name lhs))
              (length (length name)))
         (and (<= 3 length)
              (eql #\< (elt name 0))
              (eql #\> (elt name (1- length)))))))

(defun var? (var)
  (and var (symbolp var) (not (keywordp var))))

(defun pattern? (pat)
  "Every pattern PAT is either a nonterminal symbol, or a pattern
expression. Such expressions look like (OP . ARGS) where OP is one of
:SEQ :? :* :+ :OR :OR= := :*= :?= :SEQ= :@ :EOF :ITEM"
  (or (nonterminal? pat)
      (and (consp pat)
           (destructuring-bind (op . more) pat
             (case op
               ((:seq :? :* :+ :or)
                (every #'pattern? more))
               ((:or= := :*= :+= :?= :seq=)
                (not (null more)))
               (:@ (and (var? (first more))
                        (not (third more))
                        (pattern? (second more))))
               (:{} (and (car more)
                         (symbolp (car more))
                         (endp (cdr more))))
               ((:item :eof) (endp more)))))))

(defun var-pattern? (pat)
  "VAR-PATTERN? checks that a pattern is a var pattern (:@ VAR PATTERN)
and it returns VAR in that case."
  (and (consp pat)
       (third pat)
       (destructuring-bind (at var . _) pat
         (declare (ignore _))
         (and (eq at :@) (var? var) var))))

(defun collect-vars (pat)
  "Collects all of the variables from the var patterns in PAT and returns them."
  (if-let (var (var-pattern? pat))
    (list var)
    (when (consp pat)
      (append (collect-vars (car pat))
              (collect-vars (cdr pat))))))

(defun parse-rule-def (ruledef)
  (handler-case 
      (ematch ruledef
        ((guard (list lhs :match pattern)
                (and (nonterminal? lhs) (pattern? pattern)))
         (list lhs pattern (collect-vars pattern) nil nil))

        ((guard (list lhs :match pattern :if check)
                (and (nonterminal? lhs) (pattern? pattern)))
         (list lhs pattern (collect-vars pattern) check nil))
        
        ((guard (list lhs :match pattern :then action)
                (and (nonterminal? lhs) (pattern? pattern)))
         (list lhs pattern (collect-vars pattern) nil action))

        ((guard (list lhs :match pattern :then action :if check)
                (and (nonterminal? lhs) (pattern? pattern)))
         (list lhs pattern (collect-vars pattern) check action))

        ((guard (list lhs :match pattern :if check :then action)
                (and (nonterminal? lhs) (pattern? pattern)))
         (list lhs pattern (collect-vars pattern) check action)))
    (trivia::match-error ()
      (error 'invalid-rule-def :rule ruledef))))

(defun function-form-p (s)
  (or (functionp s)
      (and (consp s)
           (eq 'cl:function (first s))
           (symbolp (second s))
           (endp (cddr s)))))

(defmacro deflanguage (name (&key (documentation "")) &body ruledefs)
  (let ((bindings-var (gensym "BINDINGS")))
    (labels ((collect-let-bindings (lhs vars)
               "Create let-bindings forms for the body of the :action."
               (loop :for var :in vars
                     :collect `(,var (cdr (assoc ',var ,bindings-var))) :into bs
                     :finally (return (cons (list lhs `(cdr (assoc ',lhs ,bindings-var))) bs))))
             (expand-functional-argument (initarg lhs bindings action vars)
               (cond ((and action (symbolp action))
                      (list initarg `(lambda (,bindings-var)
                                       (let ,bindings
                                         (declare (ignorable ,lhs ,@vars))
                                         (,action ,lhs)))))
                     ((function-form-p action)
                      (list initarg `(lambda (,bindings-var)
                                       (let ,bindings
                                         (declare (ignorable ,lhs ,@vars))
                                         (funcall ,action ,lhs)))))
                     ((consp action)
                      (list initarg `(lambda (,bindings-var)
                                       (let ,bindings
                                         (declare (ignorable ,lhs ,@vars))
                                         ,action))))))
             (rule-includer (name lhs pattern &optional check action bindings vars)
               `(include-rule
                 ,name
                 (make-rule
                  :lhs ',lhs
                  :pattern ',pattern
                  ,@(expand-functional-argument :check lhs bindings check vars)
                  ,@(expand-functional-argument :action lhs bindings action vars))))) 
      `(progn
         (defvar ,name nil)
         (setf ,name (make-instance 'grammar
                                      :documentation ,documentation
                                      :start-rule ',(first (first ruledefs))))
         ,@(loop
             :for ruledef :in ruledefs
             :for (lhs pattern vars check action) := (handler-case (parse-rule-def ruledef)
                                                       (invalid-rule-def (e) (invoke-debugger e)))
             :for bindings := (collect-let-bindings lhs vars)
             :collect (rule-includer name lhs pattern check action bindings vars))

         (defmacro ,name (&body tokens)
           (argot:parse ,name tokens))))))