(in-package #:chains)

(defparameter *default-environment* '()
  "")

(let ((true (make-object :symbol (intern "TRUE" *interpreter-package*)))
      (false (make-object :symbol (intern "FALSE" *interpreter-package*))))
  (push (cons (intern "TRUE" *interpreter-package*) true) *default-environment*)
  (push (cons (intern "FALSE" *interpreter-package*) false) *default-environment*))

(defun get-var (env key)
  (if-let ((slot (assoc key env)))
    (cdr slot)
    (error "var ~A not found~% ~A~%" key env)))

;; Built-in functions and variables used inside the interpreter use their own
;; package. This allows the language to have keywords like lambda which
;; otherwise would be reserved words from the cl package

(defmacro define-function (name (&rest args) &body body)
  (let ((siblings (gensym)))
    (setf name (intern (symbol-name name) *interpreter-package*))
    `(push (cons ',name
                 (make-closure #'(lambda (environment ,siblings ,@args)
                                   (declare (ignore ,siblings))
                                   ,@body)
                               ',args
                               (complement #'identity)
                               nil
                               :function))
           *default-environment*)))

(defmacro define-function* (name (&rest args) (siblings group-predicate)
                            &body body)
  `(acons ',name
          (make-closure #'(lambda (environment ,siblings ,@args)
                            ,@body)
                        ',args
                        ,group-predicate
                        nil
                        :function)
          *default-environment*))

(defmacro define-special (name (&rest args) &body body)
  (setf name (intern (symbol-name name) *interpreter-package*))
  `(push (cons ',name
               (make-closure #'(lambda (environment siblings ,@args)
                                 ,@body)
                             ',args
                             (complement #'identity)
                             nil
                             :special))
         *default-environment*))

(defmacro define-special* (name (&rest args) (siblings group-predicate)
                          &body body)
  (setf name (intern (symbol-name name) *interpreter-package*))
  `(push (cons ',name
               (make-closure #'(lambda (environment ,siblings ,@args)
                                 ,@body)
                             ',args
                             ,group-predicate
                             nil
                             :special))
         *default-environment*))

(define-special lambda (arglist body)
  (setf arglist (remove-if #'whitespace-text-p arglist))
  (assert (every #'object-symbol-p arglist))
  (setf arglist (mapcar #'object-value arglist))
  (let ((env environment))
    (make-closure  #'(lambda (environment siblings &rest args)
                       (tree-eval (append (pairlis arglist args)
                                          env
                                          environment)
                                  body))
                   arglist (complement #'identity) env :function)))

(define-special lambda* (arglist group-predicate body)
  (setf arglist (remove-if #'whitespace-text-p arglist))
  (assert (every #'object-symbol-p arglist))
  (setf arglist (mapcar #'object-value arglist))

  (cond ((and (listp group-predicate))
         ;; TODO: Check arglist of predicate
         (setf group-predicate (first (tree-eval environment group-predicate)))

         (assert (closurep group-predicate))
         (let ((function (closure-function group-predicate)))
           (setf group-predicate #'(lambda (object)
                                     (funcall function nil nil (list object))))))
        ((not (functionp group-predicate))
         (error "~A" group-predicate)))

  (let ((env environment))
    (make-closure  #'(lambda (environment siblings &rest args)
                       (tree-eval (append (pairlis arglist args)
                                          (list (cons (intern "SIBLINGS" *interpreter-package*)
                                                      siblings))
                                          env
                                          environment)
                                  body))
                   arglist group-predicate
                   env :function)))

(defun mapflatten (function list &rest more-lists)
  (flatten (apply #'mapcar function list more-lists)))

(defun syntax-expand (table body)
  "Replace all instances inside BODY of symbols in the TABLE with their
respectives values"
  (cond ((listp body)
         (mapflatten (curry #'syntax-expand table) body))
        ((object-symbol-p body)
         (if-let (entry (assoc (object-value body) table))
           (cdr entry)
           body))
        ((chainp body)
         (make-chain (mapcar (curry #'syntax-expand table) (chain-links body))))
        (t
         body)))

;; Is this basically quasiquote?
(define-special syntax (arglist body)
  (setf arglist (remove-if #'whitespace-text-p arglist))
  (assert (every #'object-symbol-p arglist))
  (setf arglist (mapcar #'object-value arglist))
  (make-closure  #'(lambda (environment siblings &rest args)
                     (declare (ignorable environment siblings))
                     (syntax-expand (pairlis arglist args) body))
                 arglist (complement #'identity) environment :syntax))

(define-special* define (name value) (siblings #'identity)
  (assert (object-symbol-p (first name)))
  (setf name (object-value (first name)))
  (setf value (first (tree-eval environment value)))
  (tree-eval (acons name value environment)
             siblings))

;; TODO: Restrict chain link's length to avoid so many asserts

(define-function gp (symbol)
  (assert (object-symbol-p (first symbol)) nil "a")
  (setf symbol (first symbol))
  (make-closure #'(lambda (environment siblings &rest args)
                    (declare (ignorable environment siblings))
                    (let ((object (caar args)))
                      (not (and (chainp object)
                                (let ((name (caar (chain-links object))))
                                  (and (object-symbol-p name)
                                       (eq (object-value name)
                                           (object-value symbol))))))))
                (list nil) (complement #'identity) nil :function))

(define-special quote (object)
  object)