;; Copyright (c) 2003-2005 Edward Marco Baringer
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :org.unknownlamer.ucw-im)

(defvar *interface-element-type-table* (make-hash-table :test #'eql)
  "Interface element types stored by type name (symbol).")

(defclass interface-element-type ()
  ((name :accessor type-name
         :initarg :name
         :initform nil
         :documentation
         "User visible interface element type name.")
   (supertypes :accessor supertypes
               :initarg :supertypes
               :initform nil
               :documentation
               "Superior interface element types.")
   (class :accessor type-class
          :initarg :class
          :initform nil
          :documentation
          "Interface element real class.")
   (attributes :accessor attributes
               :initarg :attributes
               :initform nil
               :documentation
               "Interface element type attributes.")))

(defun %ie-type-class-name (name &optional
			    (package :org.unknownlamer.ucw-im.types))
  (intern (format nil "(INTERFACE-ELEMENT ~A::~A)"
		  (package-name (symbol-package name))
		  (symbol-name name))
          package))

(defun %register-ie-type (name supertypes type-class attributes)
  (setf (gethash name *interface-element-type-table*)
        (make-instance 'interface-element-type
                       :name name
                       :supertypes supertypes
                       :class type-class
                       :attributes attributes)))

(defmethod ie-type ((type symbol) &optional (errorp t))
  "Get interface element type."
  (aif (gethash type *interface-element-type-table*)
       it
       (when errorp
         (error "Couldn't find interface element type ~s" type))))

(defun ie-type-class (type)
  "Return real class corresponding to interface element TYPE."
  (type-class (ie-type type)))

(defun ie-type-of (obj &optional (errorp t))
  "Return TYPE-NAME, INTERFACE-ELEMENT-TYPE for OBJ or signal an error."
  (let ((cpl (mapcar #'class-name (mopp:class-precedence-list (class-of obj)))))
    (mapc #'(lambda (type-name)
              (when-bind pt (ie-type type-name nil)
                (return-from ie-type-of (values type-name pt))))
          cpl)
    (when errorp
      ;; provoke an error
      (ie-type (car cpl)))))

(defun make-ie (type &rest args)
  "Make instance of interface element."
  (apply #'make-instance (ie-type-class type) args))

(defmethod ie-type-precedence-list ((type symbol) &optional (errorp t))
  (ie-type-precedence-list (ie-type type) errorp))

(defmethod ie-type-precedence-list ((type interface-element-type) &optional (errorp t))
  (declare (ignore errorp))
  (labels ((all-supers (et &optional acc)
             (if (not (member et acc))
                 (reduce #'all-supers
                         (mapcar #'ie-type (supertypes et))
                         :from-end t
                         :initial-value (cons et acc))
                 acc)))
    (let ((supers (all-supers type)))
      (reduce #'(lambda (acc class)
                  (aif (member-if #'(lambda (et) (eq (type-class et) class))
                                  supers)
                       (nconc acc (list (type-name (car it))))
                       acc))
              (mopp:class-precedence-list (type-class type))
              :initial-value '()))))

(defmethod ie-type-attributes ((type symbol) &optional (errorp t))
  (ie-type-attributes (ie-type type) errorp))
 
(defmethod ie-type-attributes ((type interface-element-type) &optional (errorp t))
  (declare (ignore errorp))
  (remove-duplicates
   (apply #'append
          (mapcar #'(lambda (tn) (attributes (ie-type tn)))
                  (ie-type-precedence-list type)))
   :from-end t
   :key #'car))

(defun %ie-type-decl-p (decl)
  (and (consp decl) (eq 'ie-type (car decl))))

(defun %convert-ie-type-decl (decl)
  (if (%ie-type-decl-p decl)
      (class-name (apply #'ie-type-class (cdr decl)))
      decl))

(defun %convert-ie-var-decl (decl)
  (if (consp decl)
      `(,(car decl) ,(%convert-ie-type-decl (cadr decl)))
      decl))

(defun %filter-ie-types (decls)
  (reduce #'(lambda (acc decl)
              (when (%ie-type-decl-p decl)
                (push (cadr decl) acc))
              acc)
          decls
          :initial-value '()))

(defun %convert-ie-method-description (forms)
  (let ((qualifiers (do (qs) (nil)
                      (if (not (listp (car forms)))
                          (push (pop forms) qs)
                          (return qs))))
        (ll (do*
             ((fs (car forms) (cdr fs))
              (var-decl (car fs) (car fs))
              (acc '()))
             ((or (endp fs) (keywordp (car fs))) (append (nreverse acc) fs))
              (push (%convert-ie-var-decl var-decl) acc))))
    `(,@qualifiers ,ll ,@(cdr forms))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %convert-ie-definition-name (name real-name-fun)
    (if (consp name)
        (apply #'values name)
        (values name (funcall real-name-fun name)))))

(defmacro define-ie-type (name supers slots &rest class-options)
  "Define interface element type NAME and corresponding class.
NAME -- TYPE-NAME | (TYPE-NAME CLASS-NAME)."
  (labels ((expand-attribute (attr &optional (original-attr attr))
             (cond ((not (consp attr))
                    (expand-attribute (list attr nil) original-attr))
                   ((and (<= 1 (length attr) 2)
                         (eq (type-of (car attr)) 'symbol))
                    (cons (intern (symbol-name (car attr)) :keyword)
                          (or (cdr attr) '(nil))))
                   (t (error "~a is not of type (SYMBOL VALUE) or SYMBOL."
                             original-attr)))))

    (multiple-value-bind (type-name class-name)
        (%convert-ie-definition-name name #'%ie-type-class-name)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
        (eval
        `(prog1
           (defclass ,',class-name
               ,(mapcar #'%convert-ie-type-decl ',supers)
             ,',slots
             ,@(remove :attributes ',class-options :key #'car))
           (%register-ie-type ',',type-name
                            ',(%filter-ie-types ',supers)
                            (find-class ',',class-name)
                            ',',(mapcar #'expand-attribute
                                        (cdr (assoc :attributes class-options))))))))))

(defmacro define-ie-generic (name ll &rest decls)
  "Define interface element generic function."
  `(eval
    `(defgeneric ,',name ,',ll
       ,@(mapcar
          #'(lambda (decl)
              (if (eq (car decl) :method)
                  `(,(car decl) ,@(%convert-ie-method-description (cdr decl)))
                  decl))
          ',decls))))

(defmacro define-ie-method (name &body forms)
  "Define interface element method.
Method parameter declarations in the form of (VAR (IE-TYPE TYPE-NAME)) are
substituted with (VAR CLASS-NAME).
TYPE-NAME - a symbol
CLASS-NAME - name of real class corresponding TYPE-NAME."
  `(eval
    `(defmethod ,',name ,@(%convert-ie-method-description ',forms))))

(defmacro define-ie-action (name &body forms)
  "Define interface element action.
Action parameter declarations in the form of (VAR (IE-TYPE TYPE-NAME)) are
substituted with (VAR CLASS-NAME).
TYPE-NAME - a symbol
CLASS-NAME - name of real class corresponding TYPE-NAME."
  `(eval
    `(defaction ,',name ,@(%convert-ie-method-description ',forms))))
;;
;; User input conditions
;;
(define-condition ie-condition (simple-condition)
  ())

(define-condition ie-bad-input (ie-condition)
  ((value :reader ie-bad-input-value :initarg :value)
   (type :reader ie-bad-input-type :initarg :type))
  (:report (lambda (condition stream)
             (format stream
                     (simple-condition-format-control condition)
                     (ie-bad-input-value condition)
                     (ie-bad-input-type condition))))
  (:default-initargs :format-control "~a doesn't satisfy condition ~s"))

(define-condition ie-bad-input-format (ie-bad-input)
  ()
  (:default-initargs :format-control "~a doesn't satisfy format ~s"))

(define-condition ie-bad-input-type (ie-bad-input)
  ()
  (:default-initargs :format-control "~a doesn't satisfy type ~s"))

(defun signal-ie-bad-input (value required-type &optional condition-type)
  (let ((condition (ecase condition-type
                     (:format 'ie-bad-input-format)
                     (:type 'ie-bad-input-type)
                     ((nil) 'ie-bad-input))))
    (signal condition :value value :type required-type)))
;;
;; Constraint conditions
;;

(define-condition ie-constraint-violation (ie-condition)
  ())

(defun signal-ie-constraint-violation (format-control &rest format-args)
  (signal 'ie-constraint-violation
                   :format-control format-control
                   :format-arguments format-args))

(defvar *interface-element-constraint-table* (make-hash-table :test #'eql)
  "Interface element constraints stored by name (symbol).
Constraint -- function VALUE ELEMENT => T | NIL.")
;;
;; Constraints
;;
(defparameter +ie-constraint-name-prefix+
  "%")
(defparameter +ie-constraint-name-suffix+
  "-INTERFACE-ELEMENT-CONSTRAINT")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %ie-constraint-method-name (name &optional (package :ucw))
    (intern (strcat +ie-constraint-name-prefix+
                    (symbol-name name) 
                    +ie-constraint-name-suffix+)
            package)))

(defun ie-constraint (key &optional (errorp t))
  "Get interface element constraint."
  (aif (gethash key *interface-element-constraint-table*)
       it
       (when errorp
         (error "Couldn't find interface element constraint ~s" key))))

(defmacro define-ie-constraint-generic (name &rest generic-decl)
  "Create and register generic function for interface element constraint.
NAME          -- SIMPLE-NAME | (SIMPLE-NAME FUNCTION-NAME)
SIMPLE-NAME   -- KEYWORD | SYMBOL
FUNCTION-NAME -- SYMBOL."

  (multiple-value-bind (key fun-name)
      (%convert-ie-definition-name name #'%ie-constraint-method-name)
  `(progn
     (define-ie-generic ,fun-name ,@generic-decl)
     (setf (gethash ,key *interface-element-constraint-table*) ',fun-name))))

(defmacro define-ie-constraint-method (name &rest method-decl)
"Define constraint method by constraint NAME.
Constraint must be defined before with DEFINE-IE-CONSTRAINT-GENERIC."
  `(define-ie-method ,(ie-constraint name) ,@method-decl))

(define-ie-constraint-generic (:not-null validate-not-null) (value element &key &allow-other-keys)
  (:method (value element &key &allow-other-keys)
    (declare (ignore element))
    (cond ((not value)
           (signal-ie-constraint-violation "value required")
           nil)
          (t t)))
  (:documentation "Check that VALUE is not NULL."))

(define-ie-constraint-generic (:number-range validate-number-range) (value element &key min max)
  (:method ((value null) element &key min max)
    (declare (ignore element min max))
    t)
  (:method (value element &key min max)
    (declare (ignore element))
    (cond ((not value) t)
          ((<= (or min value) value (or max value)) t)
          (t (let ((format-ctrl
                  (cond
                    ((and min max) "value ~a is out of range ~a-~a")
                    (min "value ~a is less than ~a~*")
                    (max "value ~a  is greater than ~*~a"))))
               (signal-ie-constraint-violation format-ctrl value min max))
             nil)))
  (:documentation "Check that VALUE is in the range MIN - MAX."))

(define-ie-constraint-generic (:length-range validate-length-range) (value element &key min max)
  (:method ((value null) element &key min max)
    (declare (ignore element min max))
    t)
  (:method (value element &key min max)
    (declare (ignore element))
    (let ((vlength (length value)))
      (cond  ((not value) t)
             ((<= (or min vlength) vlength (or max vlength)) t)
             (t (let ((format-ctrl 
                       (cond
                         ((and min max) "length of value ~a is out of range ~a-~a")
                         (min "length of value ~a is less than ~a~*")
                         (max "length of value ~a  is greater than ~*~a"))))
                  (signal-ie-constraint-violation format-ctrl value min max))
                nil))))
  (:documentation "Check that VALUE length is in the range MIN - MAX."))

;;
;; Presentation
;;
(defclass ieview ()
  ((labelp :accessor labelp
           :initarg :labelp
           :initform t
           :documentation
           "How to present a label. 
T | :SYNGULAR - show label
:PLURAL - show plural label
NIL - don't show label."))
  (:documentation "Describe an appearence of interface element to a client."))

(define-ie-generic present (element view)
  (:method-combination wrapping-standard)
  (:documentation "Render interface element fore viewing."))

(define-ie-generic accept (element view)
  (:method-combination wrapping-standard)
  (:documentation "Render interface element fore editing."))

;;
;; Search
;;

(define-ie-generic applicable-criteria (interface-element)
  (:method-combination nconc)
  (:documentation "Search criteria applicable to INTERFACE-ELEMENT."))