Commit 6eeec969 authored by hayeah via gmail com's avatar hayeah via gmail com

Added view

- Processing may transfer from a wethod into view by calling the "render" macro.
- "render-view" may be used to render any arbitrary html template.
- view combination behaves similarly to CLOS's method.

darcs-hash:4ff86cc39aba8ac917d5aa9e3ec3c4a4c228561b
parent af55ebce
(in-package :wisp-mvc)
(define-condition werror (error)
())
(define-condition wisp-no-object-with-id (werror)
((class :initarg :class)
(id :initarg :id))
(:report (lambda (c s)
(with-slots (class id) c
(fmt :> s
"No object of class " class " stored by ID " id " is found.")))))
(define-condition wisp-undefined-view (werror)
((view-name :initarg :view-name))
(:report (lambda (c s)
(with-slots (view-name) c
(fmt :> s
"Unable to render the undefined view " view-name)))))
\ No newline at end of file
;; What happens if I output half of the page, then decided to transffer control to some other page?
;; ;; As in forward and error report.
(in-package :wisp-mvc)
;; Problem. Class methods and instance methods can't share the same name.
;; ;; I might want to (list badguy) for all instances of badguy, or (list shopping-cart), to list the content of a shopping cart instance.
;; Maybe hack together a functional interface for request with macrolet. Probably not a good idea.
(unless (wserver-socket *wserver*) (start :port 2002))
;; for class level stuff, I can first calculate the precedence-list, then do something similiar like ordinary instance method.
(in-package :wisp-mvc)
(defparameter *defined-wethods* (make-hash-table :test #'equal))
(defmacro defwethod (name (&rest arglist) &body body)
`(progn (defmethod ,name ,arglist ,@body)
(setf (gethash ,(string-invert (symbol-name name))
*defined-wethods*)
(symbol-function ',name))))
(defun find-wethod (function-name)
(defmacro defwethod (name (&rest arglist) &body body)
`(macrolet ((render (&rest args)
`(respond-with-html
(with-foo-output (*html-output-stream*)
,(if (null args)
'(render-view ',name ,@(mapcar (fn (arg-spec)
(if (consp arg-spec)
(car arg-spec)
arg-spec))
arglist))
`(render-view ,',name ,@args))))))
(progn (defmethod ,name ,arglist ,@body)
(setf (gethash ,(string-invert (symbol-name name))
*defined-wethods*)
(symbol-function ',name)))))
(defun find-generic-wethod (function-name)
(gethash function-name *defined-wethods*))
#\,))
(defparameter *wethod-arglist-init-fns* (make-hash-table :test #'equal))
(defun get-wethod-signature (req)
(cons (request-query-value "wethod-name" req)
(delimited-string-to-list (request-query-value "specializers" req)
#\,)))
(delimited-string-to-list (request-query-value "specializers" req)
#\,))
(defun get-wethod-arguments (req)
(delimited-string-to-list (request-query-value "wethod-args" req)
#\,))
(defun make-wethod-arglist (specializer-names query-arguments)
(aif (gethash specializer-names *wethod-arglist-init-fns*)
(multiple-value-list (funcall it query-arguments))
(mapcar (fn (class id)
(aif (retrieve class id)
it
(error 'no-wobject-with-id :class class :id id)))
(mapcar (fn (class arg)
(if (equal class "") arg ;; no specializer for this argument
(aif (retrieve class arg)
it
(error 'wisp-no-wobject-with-id :class class :id arg))))
specializer-names query-arguments)))
(defun apply-wethod (req)
(defun apply-instance-wethod (req)
(let* ((signature (get-wethod-signature req))
(function-name (car signature))
(specializer-names (cdr signature))
(query-arguments (get-wethod-arguments req)))
(print (symbol-package (^symbol function-name)))
(print *package*)
(apply
;;(^symbol function-name)
;;(intern (string-upcase function-name) (find-package :wisp-mvc))
;; this is pretty obscure. Intern interns to the current package.
;; Because getting the symbol this way is dynamic, what I get depends
;; on the runtime state. That is, the closure behaves differently.
;; So if I am in the wrong package, symbol-function won't find the
;; function to apply
(find-wethod function-name)
(make-wethod-arglist specializer-names query-arguments))))
(defmacro respond-with-html ((req ent) &body body)
`(let ((html-response
(let ((*html-output-stream* (make-string-output-stream)))
(declare (special *html-output-stream*))
(unwind-protect
(handler-case (progn ,@body (get-output-stream-string *html-output-stream*))
(werror (c)
;; bind a fresh output stream
(close *html-output-stream*) (setf *html-output-stream* (make-string-output-stream))
(fmt :> *html-output-stream*
"Unhandled Error Signaled." :%)
(print c *html-output-stream*)
(get-output-stream-string *html-output-stream*)))
(close *html-output-stream*)))))
(with-http-response (,req ,ent)
(with-http-body (,req ,ent)
(let ((out (request-reply-stream req)))
(write-string html-response out))))))
(function (find-generic-wethod (request-query-value "wethod-name" req)))
(query-arguments (get-wethod-arguments req)))
(apply function
(make-wethod-arglist signature query-arguments))))
(defun apply-class-wethod (req)
(let* ((class-name (^class-name (request-query-value "class-name")))
(signature (get-wethod-signature req))
(function (find-generic-wethod (request-query-value "wethod-name" req)))
(query-arguments (get-wethod-arguments req)))
(apply function
(cons class-name (make-wethod-arglist signature query-arguments)))))
......
(defpackage :wisp-util (:use :cl :cl-interpol :kmrcl) ; :it.bese.fiveam)
(:export
:split-by-separators
:^string
:^symbol
......@@ -29,8 +29,9 @@
:fmt))
(defpackage :wisp-mvc
(:use :wisp-util :cl :elephant :net.aserve :kmrcl)
(defpackage :wisp-mvc
;; wow, the dependency is getting pretty big.
(:use :wisp-util :cl :com.gigamonkeys.foo :elephant :net.aserve :kmrcl :mop)
(:export :find-instances
:find-instances*
......
(in-package :wisp-mvc)
(defparameter *defined-views* (make-hash-table :test #'equal))
(defmacro respond-with-html (&body body)
`(let ((html-response
(let ((*html-output-stream* (make-string-output-stream)))
(declare (special *html-output-stream*))
(unwind-protect
(handler-case (progn ,@body (get-output-stream-string *html-output-stream*))
(werror (c)
;; bind a fresh output stream
(close *html-output-stream*) (setf *html-output-stream* (make-string-output-stream))
(fmt :> *html-output-stream*
"Unhandled Error Signaled." :%)
(print c *html-output-stream*)
(get-output-stream-string *html-output-stream*)))
(close *html-output-stream*)))))
(with-http-response (*request* *entity*)
(with-http-body (*request* *entity*)
(let ((out (request-reply-stream *request*)))
(write-string html-response out))))))
(defun parse-method-definition (definition)
(multiple-value-bind (qualifiers fn-list/body) (split-if (compose #'not #'keywordp) definition)
(multiple-value-bind (required-args other-args) (split-if
(fn (arg)
(and (atom arg)
(equal (char (symbol-name arg) 0) #\&)))
(car fn-list/body))
(values qualifiers required-args other-args (cdr fn-list/body)))))
(defmacro defview (name &body definition)
(multiple-value-bind (qualifiers required-args other-args body) (parse-method-definition definition)
(let* ((fn-name (symcat 'view- name))
(def-generic (if (fboundp fn-name)
nil
;; make the generic function for the view
(let ((untyped-fnlist (mapcar (fn (arg-spec)
(if (consp arg-spec)
(car arg-spec)
arg-spec))
required-args)))
`(defgeneric ,fn-name (,@untyped-fnlist &allow-other-keys))))))
`(progn
,@(if def-generic
(list def-generic
`(setf (gethash ',(symbol-name fn-name) *defined-views*)
(symbol-function ',fn-name))))
(defmethod
,fn-name
,@qualifiers
,(append required-args other-args)
(html ,@body))))))
(defun find-view (view-name)
(gethash (symbol-name view-name) *defined-views*))
(defun render-view (name &rest rest)
(let ((view-name (symcat 'view- name)))
(apply (aif (find-view view-name)
it
(error 'wisp-undefined-view :view-name view-name))
rest)))
(defview object->html ((obj wisp-object))
(let* ((class (class-of obj))
;; I was hoping to use the existence of reader and writer as flag for permission of read/write
#+(or)(slot-readers (mapcar
(compose #'car #'slot-definition-readers)
(compute-slots class)))
(slot-names (mapcar #'slot-definition-name (compute-slots class))))
(html (:b (:i class))
(:table (:tr
(dolist (slot-name slot-names)
(html (:th slot-name))))
(:tr
(dolist (slot-name slot-names)
(html (:td (if (slot-boundp obj slot-name)
;; gay. Has to use :print, or else value is discarded.
;; ;; Took a long time to squash this bug. Duh.
(html (:i (:print (slot-value obj slot-name))))
nil)))))))))
;; (put 'destructure 'common-lisp-indent-function (get 'destructuring-bind 'common-lisp-indent-function))
;; (put 'dokids 'common-lisp-indent-function (get 'dotimes 'common-lisp-indent-function))
;; (put 'with-dialog-values 'common-lisp-indent-function (get 'with-slots 'common-lisp-indent-function))
;; Utterly clueless how indentation works.
(put 'defview 'common-lisp-indent-function (get 'defmethod 'common-lisp-indent-function))
(put 'defwethod 'common-lisp-indent-function (get 'defmethod 'common-lisp-indent-function))
\ No newline at end of file
......@@ -6,11 +6,17 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package 'cl-interpol)
(asdf:operate 'asdf:load-op 'cl-interpol))
(unless (find-package 'com.gigamonkeys.foo)
(asdf:operate 'asdf:load-op 'com.gigamonkeys.foo))
(unless (find-package 'elephant)
(asdf:operate 'asdf:load-op 'elephant))
(unless (find-package 'aserve)
(require :aserve))
(cl-interpol::enable-interpol-syntax)
(unless *print-right-margin* (setf *print-right-margin* 70 )))
......@@ -22,6 +28,8 @@
:components ((:file "packages")
(:file "util")
(:file "fmt")
(:file "condition")
(:file "model")
(:file "view"))
(:file "view")
(:file "control"))
:serial t)
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment