Welcome to the CHICKEN Scheme pasting service

(module ssql-record

(define-ssql-record ssql-record->insert)

(import chicken scheme)
(use coops coops-primitive-objects defstruct lolevel)

(define-generic (ssql-record->insert record))

(define-syntax define-ssql-record
  (ir-macro-transformer
   (lambda (x i c)
     (let* ((record  (symbol->string (strip-syntax (cadr x))))
            (record? (string->symbol (string-append record "?")))
            (class   (string->symbol (string-append "<" record ">")))
            (->alist (string->symbol (string-append record "->alist"))))
       `(begin
          (defstruct . ,(cdr x))
          (define-primitive-class ,class (<record>) ,record?)
          (define-method (ssql-record->insert (record ,class))
            (let ((alist (,->alist record)))
              `(insert (into ,',(string->symbol record))
                       (columns ,(map car alist))
                       (values ,(list->vector (map cdr alist)))))))))))

)

(import ssql-record)

(define-ssql-record person
  first-name last-name age)

(define angelina
  (make-person first-name: "Angela"
               last-name: "Merkel"
               age: 99))

(pp (ssql-record->insert angelina))

;; output:
 
(insert
  (into person)
  (columns (first-name last-name age))
  (values #("Angela" "Merkel" 99)))

(define *field-lists* (make-parameter '()))

; Record Type Definitions
(define object-user-fields '(name
			      type
			      description
			      image))

(define object-auto-fields '(node-id
			      seqno
			      version
			      created
			      last-modified
			      created-by-node-id
			      created-by-seqno
			      last-modified-by-node-id
			      last-modified-by-seqno))

(define object-rtd (make-record-type
		 'object
		 `(,@object-user-fields ,@object-auto-fields)))


(define make-object (record-constructor object-rtd object-user-fields))

(*field-lists* (cons `(,object-rtd . (,@object-user-fields ,@object-auto-fields))
		     (*field-lists*)))



; Methods to convert records to SSQL
(define (INSERT table-name rtd record)
  (let ((field-list (or (alist-ref rtd (*field-lists*)) '())))
    `(insert (into ,table-name)
	     (columns ,@field-list)
	     (values #(,@(map (lambda (field)
				((record-accessor rtd field) record))
			      field-list))))))


(define (field-setter rtd object)
  (let ((set (cut record-modifier rtd <>)))
    (lambda (field value)
      ((set field) object value))))

; define procedures to manipulate the objects table.
(define (object-create instance)
  (let ((set (field-setter object-rtd instance))
	(now (current-seconds))
	(node-id (get-node-id))
	(seqno (get-seqno))
	(user-node-id (user-node-id (current-user)))
	(user-seqno (user-seqno (current-user))))
    (set 'node-id node-id)
    (set 'seqno seqno)
    (set 'version 0)
    (set 'created now)
    (set 'last-modified now)
    (set 'created-by-node-id user-node-id)
    (set 'created-by-seqno   user-seqno)
    (set 'last-modified-by-node-id user-node-id)
    (set 'last-modified-by-seqno   user-seqno)
    (printf "creating object ~A:~A\n" node-id seqno)
    (INSERT "objects" object-rtd instance)
  ))

(define (object-read id)
  (printf "reading  object ~A\n" id))

(define (object-update id)
  (printf "updating object ~A\n" id))

(define (object-delete id)
  (printf "deleting object ~A\n" id))


(define (state dispatch-table)
    (lambda (verb . params)
      (or (and-let* ((proc (alist-ref verb dispatch-table)))
		    (apply proc params))
	  (abort (conc "Not a valid verb for this type of object: " verb)))))


; for now: the objects procedures are for a table, not a domain object!
;   the difference is around DB transactions and who sends the queries.
(define object (state `((create . ,object-create)
			(read   . ,object-read)
			(update . ,object-update)
			(delete . ,object-delete))))
(define (hub-make name description image)
 (make-object name 'hub description image))

(define (hub-create id)
  (printf "creating ~A\n" id)
  (object-create id))


(define hub (state `((make   . ,hub-make)
		     (create . ,object-create))))