1  (in-package :ami.modeling)
  2  
  3  (defun field-class-from-name (name)
  4    "Generate field class symbol from the name. It searches the current package to see if there is a field with that name
  5  And if not it searches it in the AMI.MODELING package."
  6    (let ((current-package-sym (alexandria:format-symbol *package* "~a-FIELD" name))
  7          (ami-modeling-sym (alexandria:format-symbol (find-package "AMI.MODELING") "~a-FIELD" name)))
  8      (if (find-class current-package-sym nil)
  9          current-package-sym
 10        (if (find-class ami-modeling-sym nil)
 11            ami-modeling-sym
 12          (error "Field ~a doesn't exist, searched in current-package (~s) and in AMI.MODELING" name (package-name *package*))))))
 13  
 14  (defun field-class-symbol-from-name (name)
 15    (alexandria:format-symbol *package* "~a-FIELD" name))
 16  
 17  
 18  ;; Field types define how types are saved to the DB and how they are rendered
 19  ;;
 20  ;; The base class is field-definition, which contains all the information needed
 21  ;; to render a field
 22  (defclass field-definition ()
 23    ((name :type string :initarg :name :accessor fdef-name :initform (error "Field `name' of field-definition left unbound"))
 24     (sym :type symbol :initarg :sym :accessor fdef-sym :initform (error "Field `sym' of field-definition left unbound"))
 25     (args :type (or nil list) :initarg :args :accessor fdef-args :initform nil)
 26     (reader :type function :initarg :reader :accessor fdef-reader)
 27     (writer :type function :initarg :writer :accessor fdef-writer)
 28     (foreign-key :type (or nil symbol) :initarg :foreign-key :accessor fdef-foreign-key)
 29     (readonly :type boolean :initarg :readonly :accessor fdef-readonly :initform nil)
 30     (nullable :type boolean :initarg :nullable :accessor fdef-nullable :initform T)
 31     (primary-key :type boolean :initarg :primary-key :accessor fdef-primary-key :initform nil)
 32     (unique :type boolean :initarg :unique :accessor fdef-unique :initform nil)))
 33  
 34  (defmethod generate-table-create-row ((fdef field-definition))
 35    (format nil "~(~s~) ~a~:[~; PRIMARY KEY~]~:[~; NOT NULL~]~:[~; UNIQUE~]~@[ REFERENCES \"~(~a~)\"(id)~]"
 36            (fdef-name fdef)
 37            (symbol-name (db-type fdef))
 38            (fdef-primary-key fdef)
 39            (and (not (fdef-primary-key fdef)) (not (fdef-nullable fdef)))
 40            (and (not (fdef-primary-key fdef)) (fdef-unique fdef))
 41            (fdef-foreign-key fdef)))
 42  
 43  (defmethod field-db-type ((fdef field-definition))
 44    "Retrieve the `DB' type depending on the field definition properties"
 45    (if (fdef-nullable fdef)
 46        `(or ,(db-type fdef) :null)
 47      (db-type fdef)))
 48  
 49  (defmethod db-type ((obj field-definition))
 50    (error "Needs to implement db-type"))
 51  
 52  (defmethod convert-from-form-data ((obj field-definition) form-data-value)
 53    form-data-value)
 54  
 55  (defmethod validate ((obj field-definition) value)
 56    (declare (ignore value))
 57    t)
 58  
 59  (defmethod render-view ((obj field-definition) &optional value)
 60    (declare (ignore value))
 61    (error "Needs to implement render-view"))
 62  
 63  (defmethod render-form ((obj field-definition) &optional value)
 64    (declare (ignore value))
 65    (error "Needs to implement render-form"))
 66  
 67  ;; Helper macros
 68  
 69  (defmacro define-field-type (name &key (inherit nil))
 70    (let ((class-name (field-class-symbol-from-name name))
 71  	(parent-class-name (when inherit 
 72  			     (field-class-symbol-from-name inherit))))
 73      `(define-simple-class ,class-name (,(or parent-class-name 'field-definition)) ())))
 74  
 75  (defmacro define-field-method (field-type method-name args body)
 76    (let ((class-name (field-class-symbol-from-name field-type))
 77  	(obj (intern (symbol-name 'obj)))
 78  	(args (mapcar (lambda (s) (when (symbolp s) (intern (symbol-name s)))) args)))
 79      `(defmethod ,method-name ((,obj ,class-name) ,@args)
 80         ,body)))
 81  
 82  (defmacro define-db-type (field-type &body body)
 83    `(define-field-method ,field-type db-type () ,@body))
 84  
 85  (defmacro define-render-form (field-type &body body)
 86    `(define-field-method ,field-type render-form (&optional value) (html ,@body)))
 87   
 88  (defmacro define-render-view (field-type &body body)
 89    `(define-field-method ,field-type render-view (&optional value) (html ,@body)))
 90  
 91  (defmacro define-validate (field-type &body body)
 92    `(define-field-method ,field-type validate (value) ,@body))
 93  
 94  
 95  (defun field-type-from-field-def (field-def)
 96    "Get the field type from a field-def list."
 97    (let* ((field-type-def (cadr field-def)))
 98      (if (listp field-type-def)
 99  	(car field-type-def)
100  	field-type-def)))
101  
102  (defun field-args-from-field-def (field-def)
103    (let* ((field-type-def (cadr field-def)))
104      (if (listp field-type-def)
105  	(cdr field-type-def)
106  	nil)))
107  
108  (define-condition field-type-doesnt-exist (error)
109    ((field-def :initarg :field-def :reader field-type-doesnt-exist-field-def)
110     (model-name :initarg :model-name :reader field-type-doesnt-exist-model-name)))
111  
112  (defmethod print-object ((err field-type-doesnt-exist) out)
113    (let ((model-name (field-type-doesnt-exist-model-name err)))
114      (format out "When defining model ~s in package ~s, an attempt to instantiate a field with an unkown type was made: " model-name (package-name (symbol-package model-name)))
115      (print-unreadable-object (err out :type t)
116        (format out "~s" (field-type-doesnt-exist-field-def err)))))
117  
118  (defun make-field-definition-from-field-def (model-name field-def)
119    "Given a field definition from a model. Create an instance of field-definition
120  for that field definition."
121    (let* ((field-name (car field-def))
122  	 (field-type (field-type-from-field-def field-def))
123  	 (field-type-class (field-class-from-name field-type))
124  	 (field-args (field-args-from-field-def field-def))
125  	 (field-properties (cddr field-def))
126           (field-full-name (alexandria:format-symbol *package* "~a-~a" model-name field-name)))
127      (unless field-type-class
128        (error 'unknown-field-type :field-type field-type))
129      (handler-case
130  	(make-instance
131  	 field-type-class
132  	 :name (symbol-name field-name)
133  	 :args field-args
134           :sym field-name
135           ;; :reader (fdefinition field-full-name)
136           ;; :writer (fdefinition `(setf ,field-full-name))
137           :foreign-key (if (eq field-type :belongs-to) (car field-args))
138  	 :nullable (and (not (in :primary-key field-properties))
139                          (not (in :not-null field-properties)))
140  	 :primary-key (in :primary-key field-properties)
141  	 :readonly (in :readonly field-properties)
142  	 :unique (and (not (in :primary-key field-properties))
143                        (in :unique field-properties)))
144        (error ()
145  	(error 'field-type-doesnt-exist
146  	       :field-def field-def
147  	       :model-name model-name)))))
148