(defpackage #:obwyn
  (:use #:cl)
  (:local-nicknames
   (#:a #:alexandria-2))
  (:export #:do>))

(in-package :obwyn)

(defun values-binding-p (form)
  #+testiere
  (:tests
   (:is (values-binding-p 'a))
   (:is (values-binding-p '(a b)))
   (:is (values-binding-p '()))
   (:is (not (values-binding-p :x)))
   (:is (not (values-binding-p '(a b 4))))
   (:is (not (values-binding-p '(a :b 4)))))
  (or (and (symbolp form)
           (not (keywordp form)))
      (and (listp form)
           (every (a:conjoin #'symbolp (complement #'keywordp)) form))))

(defun destructuring-bind-list-p (form)
  #+testiere
  (:tests
   (:is (destructuring-bind-list-p '()))
   (:is (destructuring-bind-list-p '(a b)))
   (:is (destructuring-bind-list-p '(a &rest b)))
   (:is (destructuring-bind-list-p '(a &rest b &key (x 10) y)))
   (:is (destructuring-bind-list-p '(&optional a b)))
   (:is (not (destructuring-bind-list-p 'x)))
   (:is (not (destructuring-bind-list-p '(&rest x &optional y))))
   (:is (not (destructuring-bind-list-p '(&rest 10 &optional y)))))
  (and (listp form)
       (ignore-errors
        (multiple-value-bind (required optional rest kwargs allow-other aux keyp)
            (alexandria:parse-ordinary-lambda-list form)
          (declare (ignorable required optional rest kwargs keyp))
          (not (or allow-other aux))))))

(defun expand-clauses (clauses)
  (loop :with expanded := nil
        :for (tag bindings form) :in (nreverse clauses)
        :do
           (setf expanded 
                 (ecase tag
                   (:simple
                    (cond ((null expanded) form)
                          ((eq 'cl:progn (first expanded))
                           `(progn ,form ,@(rest expanded)))
                          (t
                           `(progn ,form ,expanded))))

                   (:when
                    (cond ((null expanded) form)
                          ((eq 'cl:progn (first expanded))
                           `(when ,form ,@(rest expanded)))
                          (t
                           `(when ,form ,expanded))))

                   (:mvbind
                    `(multiple-value-bind
                           ,(if (listp bindings) bindings (list bindings))
                         ,form
                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded)))
                             (rest expanded)
                             (list expanded))))
                   (:bindif
                    `(a:when-let (,bindings ,form) 
                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded)))
                             (rest expanded)
                             (list expanded))))
                   
                   (:dsbind
                    `(destructuring-bind ,bindings ,form
                       ,@(if (and (listp expanded) (eq 'cl:progn (first expanded))) 
                             (rest expanded)
                             (list expanded))))))
        :finally (return
                   (if (and (listp expanded) (eq 'cl:progn (first expanded)))
                       `(block nil ,@(rest expanded))
                       `(block nil ,expanded)))))


(defun literals-equal (a b)
  (and (symbolp a) (symbolp b) (string-equal a b)))

(argot:deflanguage do> (:literals= #'literals-equal)
  (<start>
   :match (:seq (:* <clause>) (:eof))
   :then (expand-clauses (first <start>)))
  
  (<clause>
   :match (:or <binding-clause>
               <destructuring-clause>
               <predicate-binding-clause>
               <predicate-clause>
               <simple-clause>)) 
  
  (<binding-clause>
   :match (:seq <values-bind> (:= :=) (:item))
   :then (destructuring-bind (bindings _ form) <binding-clause>
           (declare (ignore _))
           (list :mvbind bindings form)))

  (<predicate-binding-clause>
   :match (:seq (:@ var (:item)) (:= :when=) (:@ form (:item)))
   :if (and (symbolp var) (not (keywordp var)))
   :then (list :bindif var form)
   :note "Bind variable to form, exit early if form evaluated to nil.")
  
  (<values-bind>
   :match (:item)
   :if values-binding-p
   :note "Either a symbol or a list suitable for passing to MULTIPLE-VALUE-BIND")

  (<destructuring-clause>
   :match (:seq <destructuring-list> (:= :match=) (:item))
   :then (destructuring-bind (bindings _ form) <destructuring-clause>
           (declare (ignore _))
           (list :dsbind bindings form)))

  (<destructuring-list>
   :match (:item)
   :if destructuring-bind-list-p
   :note "An list that might be passed as the first argument to DESTRUCTURING-BIND.")  

  (<predicate-clause>
   :match (:seq (:or= :when :?) (:item))
   :then (list :when nil (second <predicate-clause>)))
  
  (<simple-clause>
   :match (:@ simple (:item))
   :if (not (member simple '(:when= :match= :when :=) :test #'literals-equal))
   :then (list :simple nil simple)))