;; DoWhateverTheFuckYouWantPublicLicense

(defun builder-object (builder name)
  (or (builder-get-object builder name)
      (error "Widget ~S not found" name)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %expand-bind (widget/s access &optional (bind 'identity))
    (cond
      ((stringp widget/s)
       `(setf (widget-value (builder-object builder ,widget/s))
              (funcall #',bind ,access)))
      ((listp widget/s)
       `(setf (widget-value (builder-object builder (nth (funcall #',bind ,access) ',widget/s)))
              t))
      (t (error "Unhandled"))))
  (defun %expand-extract (widget/s access &optional (bind 'identity))
    (let ((extract (inverse bind)))
      (cond ((stringp widget/s)
             `(setf ,access (funcall #',extract (widget-value (builder-object builder ,widget/s)))))
            ((listp widget/s)
             `(loop for index from 0
                 for widget in ',widget/s
                 when (widget-value (builder-object builder widget))
                 do (progn (setf ,access (funcall #',extract index))
                           (return))
                 finally (error "There is no active widget.")))
            (t (error "Unhandled"))))))

(defmacro define-widget (class name &body connections)
  `(progn
     (defun ,(symbolicate "BIND-" name) (builder ,name)
       ,@(loop for connection in connections
            collect (apply #'%expand-bind connection)))
     (defun ,(symbolicate "EXTRACT-" name) (builder)
       (let ((,name (make-instance ',class)))
         ,@(loop for connection in connections
              collect (apply #'%expand-extract connection))
         ,name))))

(defun widget-value (widget)
  (funcall
   (typecase widget
     (toggle-button #'toggle-button-active)
     (combo-box #'combo-box-active)
     (adjustment #'adjustment-value)
     (otherwise (error "Unhandled widget type.~%~A" widget)))
   widget))

(defun (setf widget-value) (value widget)
  (funcall
   (typecase widget
     (toggle-button #'(setf toggle-button-active))
     (combo-box #'(setf combo-box-active))
     (adjustment (lambda (value widget)
                   (declare (type double-float value))
                   (setf (adjustment-value widget) value)))
     (otherwise (error "Unhandled widget type.~%~A" widget)))
   value widget))