|
@@ -0,0 +1,95 @@
|
|
|
+;;;; collect.lisp
|
|
|
+;;;;
|
|
|
+;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
|
|
|
+
|
|
|
+(in-package #:collect)
|
|
|
+
|
|
|
+;;; "collect" goes here. Hacks and glory await!
|
|
|
+
|
|
|
+(defun to-sql-type (type)
|
|
|
+ (cadr (assoc type '((:integer "INTEGER")
|
|
|
+ (:text "TEXT")
|
|
|
+ (:real "REAL")
|
|
|
+ (:blob "BLOB")))))
|
|
|
+
|
|
|
+(defun relation (relationship)
|
|
|
+ (if (not (null relationship))
|
|
|
+ (destructuring-bind (table column) relationship
|
|
|
+ (declare (string table column))
|
|
|
+ (format nil " REFERENCES ~a (~a)"
|
|
|
+ table
|
|
|
+ column))
|
|
|
+ ""))
|
|
|
+
|
|
|
+(defun col-to-clause (column)
|
|
|
+ (destructuring-bind (name type &key (nullable t) (primary nil) relationship) column
|
|
|
+ (declare (string name)
|
|
|
+ (keyword type)
|
|
|
+ (ignorable nullable relationship))
|
|
|
+ (if (null primary)
|
|
|
+ (if (null nullable)
|
|
|
+ (format nil "~a ~a~a,"
|
|
|
+ name
|
|
|
+ (to-sql-type type)
|
|
|
+ (relation relationship))
|
|
|
+ (format nil "~a ~a~a NOT NULL,"
|
|
|
+ name
|
|
|
+ (to-sql-type type)
|
|
|
+ (relation relationship)))
|
|
|
+ (format nil "~a ~a PRIMARY KEY,"
|
|
|
+ name
|
|
|
+ (to-sql-type type)))))
|
|
|
+
|
|
|
+(defmacro define-table (name (&rest cols) &key &allow-other-keys)
|
|
|
+ (let* ((clauses (map 'list #'col-to-clause cols))
|
|
|
+ (sql-command (format nil "CREATE TABLE IF NOT EXISTS ~a~%(~%~{~a~%~});"
|
|
|
+ name
|
|
|
+ clauses)))
|
|
|
+ `(list ,sql-command)))
|
|
|
+
|
|
|
+(defun make-form-entry (entry)
|
|
|
+ (destructuring-bind (label column &key (type :text) other-column options) entry
|
|
|
+ (declare (string label column)
|
|
|
+ (ignorable other-column options))
|
|
|
+ (let ((label-name (concatenate 'string "fld_" column))
|
|
|
+ (the-options (if (null options)
|
|
|
+ (if (not (null other-column))
|
|
|
+ `(,(car other-column) ,(cadr other-column))))))
|
|
|
+ (case type
|
|
|
+ (:text
|
|
|
+ `(:tr
|
|
|
+ (:td ,label)
|
|
|
+ (:td (:input :type :text
|
|
|
+ :name ,label-name))))
|
|
|
+ (:drop-down
|
|
|
+ `(:tr
|
|
|
+ (:td ,label)
|
|
|
+ (:td
|
|
|
+ (:select :name ,label-name
|
|
|
+ (loop for option in ,the-options
|
|
|
+ collect (make-option-drop-down option))))))
|
|
|
+ (:radio-buttons
|
|
|
+ `(:tr
|
|
|
+ (:td ,label)
|
|
|
+ (:td (loop for option in ,the-options
|
|
|
+ collect (make-option-radio option ,label-name)))))))))
|
|
|
+
|
|
|
+(defun make-option-drop-down (option)
|
|
|
+ (let ((name (first option))
|
|
|
+ (value (second option)))
|
|
|
+ `(:option :value ,value ,name)))
|
|
|
+
|
|
|
+(defun make-option-radio (option label)
|
|
|
+ (let ((name (first option))
|
|
|
+ (value (second option)))
|
|
|
+ `(:div (:input :type "radio" :name ,label :value ,value)
|
|
|
+ ,name (:br))))
|
|
|
+
|
|
|
+(defmacro define-form (name table (&rest fields) &key &allow-other-keys)
|
|
|
+ (let* ((columns (map 'list #'second fields))
|
|
|
+ (field-names (map 'list #'(lambda (column)
|
|
|
+ (concatenate 'string "fld_" column))
|
|
|
+ columns))
|
|
|
+ (form-entries (map 'list #'make-form-entry fields)))
|
|
|
+ `(list (list ,@columns)
|
|
|
+ (list ,@field-names))))
|