(in-package :hu.caleb)

;; TODO: &allow-other-keys

(defun alist-for-remaining-args (remaining-args)
  (loop with alist = nil
        while (not (eq remaining-args nil))
        do (let ((sym (pop remaining-args))
                 (value (pop remaining-args)))
             (assert (keywordp sym))
             (push (cons (symbol-name sym) value) alist))
        finally (return alist)))

(defun destructure (evaluator binder lambda-list arglist
                    &key (allow-destructure nil) (is-toplevel t)
                    &aux was-rest was-whole was-key key-forms (current-arglist arglist))
  
  (when (eq lambda-list nil)
    (return-from destructure))
    
  (when (symbolp lambda-list)
    (assert (not is-toplevel))
    (funcall binder lambda-list arglist)
    (return-from destructure nil))
  
  (loop with state = :required
        for specifier in lambda-list
        do (case specifier
             (&optional (setq state :optional))
             (&rest (setq state :rest))
             (&body (setq state :rest))
             (&key (setq state :key))
             (&aux (assert is-toplevel) (setq state :aux))
             (&whole (setq state :whole))
             (otherwise
              ; This is a symbol in the lambda list, treat it appropriately
              (case state
                (:required
                 ; consume an argument and bind it
                 (assert (not (eq current-arglist nil)))
                 (when (not allow-destructure) (assert (symbolp specifier)))
                 (destructure evaluator binder specifier (pop current-arglist) :allow-destructure t :is-toplevel nil))

                (:optional
                 (assert (not was-key))
                 (let (var default-value supplied-p supplied)
                   ; Decode specifier, this should be done with a 'destructuring-bind this,
                   ; if does not match, then destructuring-bind that' operator
                   
                   (cond
                    ((symbolp specifier)
                     (setq var specifier default-value nil supplied-p nil))
                    ((and (listp specifier) (eq (length specifier) 1))
                     (setq var (nth 0 specifier) default-value nil supplied-p nil))
                    ((and (listp specifier) (eq (length specifier) 2))
                     (setq var (nth 0 specifier) default-value (nth 1 specifier) supplied-p nil))
                    ((and (listp specifier) (eq (length specifier) 3))
                     (setq var (nth 0 specifier) default-value (nth 1 specifier) supplied-p (nth 2 specifier))
                     (assert (symbolp supplied-p)))
                    (t
                     ; Invalid optional specifier, raise an error
                     (assert nil)))

                   (when (not allow-destructure) (assert (symbolp var)))
                   (setq supplied (not (eq current-arglist nil)))

                   (unless (eq supplied-p nil)
                     (funcall binder supplied-p supplied))

                   (if supplied
                     (destructure evaluator binder var (pop current-arglist) :allow-destructure t :is-toplevel nil)
                     (funcall evaluator var default-value))))
                (:rest
                 (assert (symbolp specifier))
                 (assert (not was-rest))
                 (assert (not was-key))
                 (setq was-rest t)
                 (funcall binder specifier current-arglist))

                (:whole
                 (assert (symbolp specifier))
                 (assert (not was-whole))
                 (assert (not was-key))
                 (setq was-whole t)
                 (funcall binder specifier arglist))

                (:aux
                 (let (var init-form)
                   (cond
                    ((symbolp specifier)
                     (setq var specifier init-form nil))
                    ((and (listp specifier) (eq (length specifier) 2))
                     (setq var (nth 0 specifier) init-form (nth 1 specifier)))
                    (t
                     ; Invalid aux variable
                     (assert nil)))

                   (assert (symbolp var))
                   (funcall evaluator var init-form)))

                (:key
                 (setq was-key t)
                 (let (var default-value supplied-p)
                   ; TODO: this is code duplication from :optional handler
                   (cond
                    ((symbolp specifier)
                     (setq var specifier default-value nil supplied-p nil))
                    ((and (listp specifier) (eq (length specifier) 1))
                     (setq var (nth 0 specifier) default-value nil supplied-p nil))                    
                    ((and (listp specifier) (eq (length specifier) 2))
                     (setq var (nth 0 specifier) default-value (nth 1 specifier) supplied-p nil))
                    ((and (listp specifier) (eq (length specifier) 3))
                     (setq var (nth 0 specifier) default-value (nth 1 specifier) supplied-p (nth 2 specifier))
                     (assert (symbolp supplied-p)))
                    (t
                     ; Invalid key specifier, raise an error
                     (assert nil)))
                   
                   (when (not allow-destructure) (assert (symbolp var)))
                   (push (list var default-value supplied-p) key-forms)))
                 
                )))
        )
  
  ; now process keyword arguments

  (unless was-key
    (return-from destructure nil))
  
  (assert (evenp (length current-arglist)))

  (loop with keyword-alist = (alist-for-remaining-args current-arglist)
        for (var default-value supplied-p) in key-forms
        do (let* ((found
                   (assoc (symbol-name var) keyword-alist :test 'equal))
                  
                  (supplied
                   (not (eq found nil))))
             
             (unless (eq supplied-p nil)
               (funcall binder supplied-p supplied))

             (if supplied
               (progn
                 (when (not allow-destructure) (assert (symbolp var)))
                 (destructure evaluator binder var (cdr found) :allow-destructure t :is-toplevel nil))
               (funcall evaluator var default-value))))
  )