Initial commit

.gitignore

@@ -0,0 +1,10 @@
+.*
+!.gitignore
+*.aux
+*.bcf
+*.log
+*.out
+*.run.xml
+auto/*
+*~
+\#*\#

README.txt

@@ -0,0 +1 @@
+This is the stub README.txt for the "collect" project.

collect.asd

@@ -0,0 +1,17 @@
+;;;; collect.asd
+;;;;
+;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
+
+(asdf:defsystem #:collect
+  :description "Describe collect here"
+  :author "Samuel W. Flint <swflint@flintfam.org>"
+  :license "GNU GPLv3 or later"
+  :depends-on (#:restas
+               #:html-template
+               #:cl-who
+               #:lass
+               #:parenscript
+               #:sqlite)
+  :serial t
+  :components ((:file "package")
+               (:file "collect")))

collect.lisp

@@ -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))))

package.lisp

@@ -0,0 +1,7 @@
+;;;; package.lisp
+;;;;
+;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>
+
+(defpackage #:collect
+  (:use #:cl
+        #:iterate))