(use-package :closer-mop)

(defclass curried-function ()
  ()
  (:metaclass funcallable-standard-class))

(defun funcall-curried (f &rest args)
  (loop with fn = f
        for arg in args do (setf fn (funcall fn arg))
        finally (return (if (functionp fn)
                          (make-curried-function-wrapper fn)
                          fn))))

(defun make-curried-function-wrapper (curried-function)
  (let ((f (make-instance 'curried-function)))
    (set-funcallable-instance-function
      f (lambda (&rest args)
          (declare (dynamic-extent args))
          (if (null args)
            (funcall curried-function)
            (apply #'funcall-curried curried-function args))))
      f))

(defmacro curried-lambda ((&rest args) &body body)  
  (assert (every (lambda (x)
                   (and (symbolp x)
                        (not (member x '(&aux &rest &optional &key)))))
                 args)
          () "Invalid curried function lambda list:" args)
  (labels ((curry (arg-list)
             (if (null (cdr arg-list))
               `(lambda ,(and arg-list (list (car arg-list)))
                  ,@body)
               `(lambda (,(car arg-list))
                  ,(curry (rest arg-list))))))
    `(make-curried-function-wrapper ,(curry args))))

(defmacro defcurried (name (&rest args) &body body)
  (let ((arg-list (gensym "ARGS")))
    `(labels ((,name (&rest ,arg-list)
                (apply #'funcall-curried
                       (curried-lambda ,args ,@body)
                       ,arg-list)))
       (setf (symbol-function ',name)
             (curried-lambda ,args ,@body))
       ',name)))

(defmacro curried-flet ((&rest bindings) &body body)
  (let ((gensyms (mapcar (lambda (x)
                           (declare (ignore x))
                           (gensym)) bindings)))
    `(let (,@(loop for binding in bindings
                   for temp-name in gensyms
                   collect (destructuring-bind
                             (name (&rest args) &body body) binding
                             (assert (symbolp name) ())
                             `(,temp-name (curried-lambda ,args ,@body)))))
       (flet (,@(loop for binding in bindings
                        for temp-name in gensyms
                        for name = (car binding) collect
                        `(,name (&rest args)
                                (apply #'funcall-curried ,temp-name args))))
         ,@body))))

(defmacro curried-labels ((&rest bindings) &body body)
  `(labels (,@(loop for binding in bindings
                 collect (destructuring-bind
                           (name (&rest args) &body body) binding
                           `(,name (&rest args)
                              (apply #'funcall-curried
                                     (curried-lambda ,args ,@body)
                                     args)))))
         ,@body))

(defmacro def (name value)
  (let ((val (gensym)))
  `(let ((,val ,value))
     (if (functionp ,val)
       (setf (symbol-function ',name) ,val)
       (setf (symbol-value ',name) ,val))
     ',name)))