+++ /dev/null
-;; -*- lisp -*-
-
-(in-package :common-lisp-user)
-
-#+cmu
-(defun init-cmu-mp ()
- ;; this isn't strictly necessary, but scheduling feels very coarse
- ;; without startup-idle-and-top-level-loops, leading to answer delays
- ;; of about 1s per request.
- (unless (find-if
- #'(lambda (proc) (string= (mp:process-name proc) "Top Level Loop"))
- (mp:all-processes))
- (mp::startup-idle-and-top-level-loops)))
-
-#+cmu
-(init-cmu-mp)
-
-;;;; * UCW server initialization "script"
-
-;;;; This file is meant to be loaded by ucwctl, but you can use it a
-;;;; general "startup ucw" file as well. You should customize this
-;;;; script to load/prepare your application.
-
-;;;; ** Loadup dependencies
-
-;;;; Load arnesi first so we can set arnesi::*call/cc-returns* before
-;;;; ucw is compiled and loaded.
-(asdf:oos 'asdf:load-op :arnesi)
-(setf arnesi::*call/cc-returns* nil)
-
-;;;; Load up UCW itself
-(asdf:oos 'asdf:load-op :ucw)
-
-(in-package :it.bese.ucw-user)
-
-#+(and sbcl sb-unicode)
-(setf (external-format-for :slime) :utf-8-unix
- (external-format-for :url) :utf-8
- (external-format-for :http-emacsen) :utf-8-unix
- (external-format-for :http-lispish) :utf-8)
-
-;;;; Load the default applications systems
-
-(asdf:oos 'asdf:load-op :ucw.examples)
-(asdf:oos 'asdf:load-op :ucw.admin)
-(asdf:oos 'asdf:load-op :lisp-on-lines)
-(asdf:oos 'asdf:load-op :lisp-on-lines.example)
-
-;;;; Let there be swank.
-(swank:create-server :port 4007)
-
-;;;; Finally startup the server
-
-;;;; ** Finally startup the server
-
-(ucw:create-server :backend :araneida
-
- ;; :httpd
- ;; :mod-lisp
- ;; :aserve
- :host "merlin.tech.coop"
- :port 8082
- :applications (list
- lol::*lol-example-application*)
- :inspect-components nil
- :log-root-directory (make-pathname :name nil :type nil
- :directory (append (pathname-directory *load-truename*)
- (list :up "logs"))
- :defaults *load-truename*)
- :log-level +info+
- :start-p t)
-
-;;;; ** Allocate one database connection per thread :
-
-(defmethod araneida:handle-request-response :around ((handler ucw::ucw-handler) method request)
- (clsql:with-database (my-db '("localhost" "lol" "lol" "lol") :pool t)
- (clsql:with-default-database (my-db)
- (call-next-method))))
-
-(publish-directory (server.backend *default-server*) #P"/home/drewc/src/site/lisp-on-lines/wwwroot/dojo/" "/dojo/")
-(publish-directory (server.backend *default-server*) #P"/home/drewc/src/site/lisp-on-lines/wwwroot/prototype/" "/prototype/")
-
-(publish-directory (server.backend *default-server*) #P"/home/drewc/src/sunrise/wwwroot/" "/")
-
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; for when there is nothing left to display.
-(defcomponent empty-page (window-component)
- ())
-
-(defmethod render-on ((res response) (self empty-page))
- "didnt find a thing")
-
-(defcomponent auto-complete ()
- ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
- (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
- (client-value
- :accessor client-value
- :initform ""
- :documentation "The string the user has, so far, insterted.")
- (index
- :accessor index
- :initform nil
- :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax")
- (list-of-values
- :accessor list-of-values
- :initform '()
- :documentation "The list generated by values-generator")
- (values-generator :accessor values-generator :initarg :values-generator
- :documentation "Function which, when passed the auto-complete component, returns a list of objects.")
- (value
- :accessor value
- :initform nil
- :documentation "The lisp value of the object selecting in the drop down")
- (as-value :accessor as-value :initarg :as-value
- :documentation "Function which, when passed a value, returns the string to put in the text box.")
- (render-it :accessor render-it :initarg :render
- :documentation "Function which, when passed the component and one of the values render it (the value).")
- (input-size :accessor input-size :initarg :input-size :initform 20)
- (submit-on-select-p
- :accessor submit-on-select-p
- :initarg :submit-on-select-p
- :initform t)
- (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output)))
-
-(defmethod js-on-complete ((l auto-complete))
- `(lambda (transport)
- (setf (slot-value (document.get-element-by-id ,(output-id l))
- 'inner-h-t-m-l)
- transport.response-text)))
-
-(defmacro make-action-url (component action)
- "
-There has got to be something like this buried in UCW somewhere,
-but here's what i use."
- `(ucw::print-uri-to-string
- (compute-url ,component
- :action-id (ucw::make-new-action (ucw::context.current-frame *context*)
- (lambda ()
- (arnesi:with-call/cc
- ,action))))))
-
-(defun generate-ajax-request (js-url &optional js-options)
- `(new
- (*Ajax.*Request
- ,js-url
- ,js-options)))
-
-(defmacro with-ajax-request (js-url &rest js-options)
- `(generate-ajax-request-for-url
- ,js-url
- ,@js-options))
-
-(defmacro with-ajax-action ((component) &body action)
- `(generate-ajax-request
- (make-action-url ,component (progn ,@action))))
-
-
-(defun make-auto-complete-url (input-id)
- "creates a url that calls the auto-complete entry-point for INPUT-ID."
- (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A"
- input-id "session"
- (ucw::session.id (ucw::context.session ucw::*context*))))
-
-(defmethod/cc on-submit ((l auto-complete))
- ())
-
-(defmethod js-on-select ((l auto-complete))
- "the javascript that is called when an item is selected"
- (when (submit-on-select-p l)
- `(progn
- (set-action-parameter ,(register-action
- (lambda ()
- (arnesi:with-call/cc
- (on-submit l)))))
- (submit-form))))
-
-
-(defmethod render ( (l auto-complete))
- ;; session-values are stored in an eql hash table.
- (let ((input-key (intern (input-id l))))
- ;; We are storing the input components in the session,
- ;; keyed on the string that we also use as the id for
- ;; the input field.
-
- (unless (get-session-value input-key)
- (setf (get-session-value input-key) l))
-
- ;; A hidden field to hold the index number selected via javascript
- (<ucw:text :accessor (client-value l)
- :id (input-id l) :size (input-size l))
- (<:div :id (output-id l) :class "auto-complete" (<:as-html " ")))
- (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l))))
- (f (make-symbol (format nil "~A.select-entry-function"a))))
- (<ucw:script
- `(setf ,a
- (new
- (*Ajax.*Autocompleter
- ,(input-id l) ,(output-id l)
- ,(make-auto-complete-url (input-id l))
- (create
- :param-name "value"))))
- `(setf ,f (slot-value ,a 'select-entry))
- `(setf (slot-value ,a 'select-entry)
- (lambda ()
- (,f)
- ,(generate-ajax-request
- (make-auto-complete-url (input-id l))
- `(create
- :parameters (+ "&index=" (slot-value ,a 'index))
- :method "post"
- :on-complete (lambda (res)
- ,(js-on-select l)))))))))
-
-
-;;;; * auto-complete-ouput
-
-
-(defcomponent auto-complete-output (window-component)
- ((auto-complete :initarg :auto-complete :accessor auto-complete)))
-
-(defmethod render ((output auto-complete-output))
- (let ((auto-complete (auto-complete output)))
- (setf (list-of-values auto-complete)
- (funcall (values-generator auto-complete) (client-value auto-complete)))
- (<:ul
- :class "auto-complete-list"
- (arnesi:dolist* (value (list-of-values auto-complete))
- (<:li
- :class "auto-complete-list-item"
- (funcall (render-it auto-complete) value))))
- (answer-component output t)))
-
-(defcomponent fkey-auto-complete (auto-complete)
- ())
-
-(defmethod js-on-select ((self fkey-auto-complete))
- (with-ajax-action (self)
- (mewa::sync-foreign-instance (ucw::parent self) (value self))))
-
-(defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation)
- ((original-value :accessor original-value :initform nil)
- (search-slots :accessor search-slots :initarg :search-slots :initform nil)
- (live-search
- :accessor live-search
- :component fkey-auto-complete))
- (:type-name ajax-foreign-key))
-
-
-(defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
- (let* ((l (live-search slot))
- (slot-name (slot-name slot))
- (instance (instance (ucw::parent slot)))
- (foreign-instance (explode-foreign-key instance slot-name))
- (class-name (class-name
- (class-of foreign-instance))))
- ;; If no search-slots than use the any slots of type string
- (unless (search-slots slot)
- (setf (search-slots slot) (find-slots-of-type foreign-instance)))
-
- (setf (lisp-on-lines::values-generator l)
- (lambda (input)
- (word-search class-name
- (search-slots slot) input)))
-
- (setf (lisp-on-lines::render-it l)
- (lambda (val)
- (<ucw:render-component
- :component (make-presentation val :type :one-line))))))
-
-(defmethod/cc revert-foreign-slot ((slot ajax-foreign-key-slot-presentation))
- (setf (lol::value (live-search slot)) nil)
- (when (original-value slot)
- (mewa::sync-foreign-instance slot (original-value slot))))
-
-(defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance)
-
- (let ((foreign-instance
- (if (lol::value (live-search slot))
- (lol::value (live-search slot))
- (setf (original-value slot)
- (when (presentation-slot-value slot instance)
- (meta-model:explode-foreign-key instance (slot-name slot)))))))
-
- (flet ((render-s () (when foreign-instance (call-next-method))))
-
- (if (slot-boundp slot 'ucw::place)
- (cond
- ((editablep slot)
- (when foreign-instance
- (setf (client-value (live-search slot))
- (with-output-to-string (s)
- (yaclml:with-yaclml-stream s
- (present (make-presentation foreign-instance
- :type :one-line))))))
-
- (<ucw:render-component :component (live-search slot))
- #+ (or) (<ucw:submit :action (revert-foreign-slot slot)
- :value "Undo")
- #+ (or) (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline"))
- ((mewa::linkedp slot)
- (<ucw:a :action (mewa::view-instance slot foreign-instance)
- (render-s)))
- (t
- (render-s)))
- ;; presentation is used only for rendering
- (render-s))))
-)
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defmethod/cc read-instance ((self component) instance)
- "View an existing instance"
- (call 'crud-viewer :instance instance))
-
-(defmethod/cc update-instance ((self component) instance)
- "Edit an instance, possibly a newly created one"
- (call 'crud-editor :instance instance))
-
-(defmethod/cc create-instance ((self component) class &rest initargs)
- "Create a new instance and edit it."
- (update-instance self (apply #'make-instance class initargs)))
-
-(defun %delete-instance-and-return-nil (instance)
- "returns nil on success"
- (handler-case (clsql:delete-instance-records instance)
- (error (x)
- (return-from %delete-instance-and-return-nil x)))
- nil)
-
-(defun display-as-string (instance)
- (with-output-to-string (s)
- (yaclml:with-yaclml-stream s
- (display (make-instance 'component) instance
- :layers '(+ as-string)))))
-
-(defmethod/cc delete-instance ((self component) instance)
- (when (call 'option-dialog
- :message (format nil "Really Delete ~A" (display-as-string instance))
- :options '((t "Yes, really delete it,")
- (nil "No, i'll hold on to this one.")))
- (let ((delete-failed (%delete-instance-and-return-nil instance)))
- (if (not delete-failed)
- (answer t)
- (progn
- (call 'info-message :message delete-failed)
- (answer t))))))
-
-
-(defmethod breadcrumb-name (component)
- (string-downcase (string (class-name (class-of component)))))
-
-(defun render-breadcrumb (self)
- (<:p :class "breadcrumb"
- (let ((count 0)
- (trail-length 3))
- (labels ((find-call-stack-for-crumbs (component list-of-parents)
- (cond ((and (not (null component))
- (> trail-length count))
- (incf count)
- (find-call-stack-for-crumbs
- (when (slot-boundp component 'ucw::calling-component)
- (slot-value component 'ucw::calling-component))
- (cons component list-of-parents)))
- (t
- list-of-parents))))
- (loop
- :for c
- :on (find-call-stack-for-crumbs self nil)
- :do (let ((c c))
- (<:as-html " / ")
- (if (cdr c)
- (<ucw:a
- :action (answer-component (second c) nil)
- (<:as-html (breadcrumb-name (first c))))
- (<:as-html (breadcrumb-name (first c))))))))))
-
-(defcomponent crud ()
- ((instance :accessor instance :initarg :instance :initform nil))
- (:documentation "The base class for all standard crud components"))
-
-(defmethod render ((self crud))
- "Just to show off more of LOL, we'll use its display mechanism for UCW components.
-
-DISPLAY takes two required arguments,
-COMPONENT : The component to display FROM (not neccesarily 'in')
-OBJECT : The 'thing' we want to display... in this case it's the component,
-
-DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time.
-
-By default, the display method iterates through the ATTRIBUTES
-of the DESCRIPTION of the OBJECT. This will hopfully become clear.
-
-In this case, we are displaying the component from itself.
-"
-
- (display self self))
-
-(defun class-name-of (instance)
- (class-name (class-of instance)))
-
-;;;; We'll use this in a string attribute to display the title.
-(defgeneric find-title (crud)
- (:method (crud)
- (if (instance crud)
- (format nil "An instance of ~A" (class-name-of (instance crud)))
- "Welcome to Crud 1.0")))
-
-;;;; ** We define an attribute for the menu
-;;;; DEFATTRIBUTE is like defclass for attributes.
-(defattribute crud-menu ()
- ()
- (:default-properties
- :show-back-p t)
- (:documentation
- "A Custom menu attribute"))
-
-(defdisplay :wrapping ((menu crud-menu) object (component component))
- "Set up the menu with an optional back button
-
-In a DEFDISPLAY form, the variable SELF is bound to the component we are displaying.
-This allows it to work with UCW's CALL and ANSWER, and saves some typing as well.
-One can also provide a name (or a specializer) for the component as the third parameter
-in the defdisplay argument list, (as i did above) but this is optional.
-
-DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION,
-which does the real work. Macroexpand if you're interested."
- (<:ul
- (when (show-back-p menu)
- (<:li (<ucw:a :action (answer nil)
- (<:as-html "Go Back"))))
- (call-next-method)))
-
-(defdisplay ((menu crud-menu) object)
- "Do nothing beyond the defalt for our standard menu
-
-note the omitted COMPONENT argument. sugar is all."
- t)
-
-;;;; create a new layer for some customisations.
-(deflayer crud)
-
-;;;; we don't really _have_ to do this in our own layer,
-;;;; but it does give us the ability to turn the behaviour off.
-(defdisplay :in-layer crud
- :wrap-around ((attribute standard-attribute) (object crud))
- "Around every attribute of a CRUD instance, i'd like to wrap a div."
- (<:div
- :class (format nil "crud-~A" (string-downcase
- (string (attribute-name attribute))))
- (call-next-method)))
-
-;;;; A description contains attributes.
-;;;; ATTRIBUTES are the various pieces that come together to make a display
-;;;; In this case, we define parts of the 'page'.
-
-(defdescription crud ()
- (;; use a generic function for the title attribute
- (title
- ;; attributes have types.
- ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list.
- :type 'string
- ;; almost all attributes have a getter and/or setter function
- ;; which is passed the object being displayed.
- ;; You can also use :SLOT-NAME
- ;; see ATTRIBUTE-VALUE for details.
- :getter #'find-title)
-
- ;; our breadcrumb function renders itself,
- ;; and does not return a value.
- (breadcrumb
- ;; the FUNCTION type calls a function
- ;; again, passing the object.
- :type 'function
- :function #'render-breadcrumb
- ;; We need to specify IDENTITY here,
- ;; as the default :GETTER calls
- ;; SLOT-VALUE on the name of the attribute.
- :getter #'identity)
- ;; So we don't need a getter in INSTANCE.
- (instance
- ;; the DISPLAY type calls DISPLAY
- ;; passing the component and the object
- ;; along with any arguments specified using the
- ;; :DISPLAY property
- :type 'display
- :display '(:layers (+ show-attribute-labels)))
- ;; this is our menu, a custom attribute
- (menu
- :type 'crud-menu))
- (;; now we create a LINE in the default layer.
- ;; LINES describe how an object is displayed
- ;; when that layer is active.
- :in-layer
- t
- :attributes '(breadcrumb title menu instance)
- :layers '(- show-attribute-labels + crud)))
-
-
-;;;; That's the basic outline of our app, now we fill in the blanks.
-
-;;;; ** Viewer
-(defcomponent crud-viewer (crud)
- ()
- (:documentation "A component for viewing objects"))
-
-(defdisplay ((menu crud-menu) (crud crud-viewer))
- "Allow the user to edit and delete the object"
- (<:li (<ucw:a :action (delete-instance crud (instance crud))
- (<:as-html "DELETE this object.")))
- (<:li (<ucw:a :action (update-instance crud (instance crud))
- (<:as-html "EDIT this object."))))
-
-;;;; ** Editor
-;;;; (use the same component for creating and editing,
-;;;; with a little magic to make it all work.
-(defcomponent crud-editor (crud validation-mixin)
- ())
-
-(defmethod/cc ensure-instance ((self crud-editor))
- "This one does a little magic, see SYNC-INSTANCE"
- (meta-model::sync-instance (instance self)))
-
-(defmethod find-title ((crud crud-editor))
- (<:as-html "Editing a "
- (class-name (class-of (instance crud)))
- " ")
- (unless (meta-model:persistentp (instance crud))
- (<:as-html "(new)")))
-
-(defattribute crud-editor-attribute (display-attribute)
- ()
- (:type-name crud-editor))
-
-(defdisplay :around ((ed crud-editor-attribute) object)
- (with-active-layers (editor show-attribute-labels wrap-form)
- (call-next-method)))
-
-
-(defdescription crud-editor ()
- ((instance :type 'crud-editor))
- (:in-layer
- t
- :default-attributes
- `((instance
- :display
- (:form-buttons
- ((:value ,(if (meta-model:persistentp (instance self))
- "Save"
- "Create")
- :action ,(action (self object)
- (ensure-instance self)
- (answer (instance self))))
- (:value
- "Cancel"
- :action
- ,(action (self object)
- (setf (instance self) nil)
- (answer nil)))))))))
-
-;;;; ** Summary
-(defcomponent crud-summary (crud)
- ((class :accessor db-class :initarg :class)
- (limit :accessor row-limit :initform 25)
- (offset :accessor row-offset :initform 0)))
-
-(defmethod find-title ((crud crud-summary))
- (format nil "Viewing Summary of ~A" (db-class crud)))
-
-(defun find-some (class limit offset)
- (clsql:select class :limit limit :offset offset :flatp t))
-
-(defmethod find-summary ((crud crud-summary))
- (find-some (db-class crud)
- (row-limit crud)
- (row-offset crud)))
-
-(defdescription crud-summary ()
- ()
- (:in-layer t
- ;;; here we show :default-attributes
- ;;; the attributes themselves can vary by layer
- ;;; the same syntax is supported in an :ATTRIBUTES form
- ;;; but that also specifies which attributes to display
- :default-attributes
- `((instance
- :getter ,#'find-summary
- :display
- (:layers (+ one-line)
- :list-item
- (:layers (+ lol::wrap-link + lol::show-attribute-labels)
- :link-action ,(action (self obj)
- (call 'crud-viewer :instance obj))))))))
-
-(defdisplay ((menu crud-menu) (object crud-summary))
- (<:li (<ucw:a
- :action (create-instance object (db-class object))
- (<:as-html "(Create New " (db-class object) ")"))))
-
-(defmethod/cc call-crud-summary ((self component) class)
- (call 'crud-summary :class class))
-
-
-(defcomponent crud-database (crud)
- ())
-
-(defdescription crud-database ()
- ((instructions
- :type 'string
- :getter (constantly "View Object Summary: "))
- (instance
- :type 'display
- :getter #'(lambda (obj)
- (declare (ignore obj))
- (meta-model::list-base-classes :clsql))
- :display `(:layers (+ one-line)
- :list-item
- (:layers (+ lol::wrap-link )
- :link-action ,(action (self class)
- (call-crud-summary self class))))))
- (:in-layer
- t
- :attributes '(title menu instructions instance)))
\ No newline at end of file
+++ /dev/null
-(in-package :lol)
-
-
-;;;; * Dojo Javascript Components
-(defcomponent dojo-component ()
- ((requires :accessor requires :initarg :requires :initform nil)))
-
-(defmethod render-requires ((self dojo-component))
- (<ucw:script `(progn ,@(loop for r in (requires self)
- collect `(dojo.require ,r)))))
-
-(defmethod render :wrapping ( (self dojo-component))
- (render-requires self)
- (call-next-method))
-
-(defmethod lol::present :around ((self dojo-component))
- (render-requires self)
- (call-next-method))
-
-(defcomponent dojo-ajax-output-component (window-component)
- ((component :accessor component :initarg :component :component dojo-component)))
-
-(defmethod render ((self dojo-ajax-output-component))
- (lol::present self))
-
-(defmethod lol::present ((self dojo-ajax-output-component))
- (present-output (component self)))
-
-(defcomponent dojo-input-component-mixin ()
- ((input-id
- :accessor input-id
- :initform (arnesi:random-string 32 arnesi::+ALPHANUMERIC-ASCII-ALPHABET+))))
-
-(defcomponent dojo-output-component-mixin ()
- ((output-id
- :accessor output-id
- :initform (arnesi:random-string 32 arnesi::+ALPHANUMERIC-ASCII-ALPHABET+))
- (output-component
- :accessor output-component
- :component dojo-ajax-output-component)))
-
-(defmethod shared-initialize :after ((self dojo-output-component-mixin) slots &rest args)
- (declare (ignore slots args))
- (setf (component (output-component self)) self))
-
-
-(defmacro with-ajax ((component) &body args)
- (multiple-value-bind (actions callbacks args output)
- (loop for arg in args
- if (eql (car arg) :action)
- nconc (cdr arg) into actions
- else if (eql (car arg) :callback)
- collect (cdr arg) into callbacks
- else if (eql (car arg) :output-to)
- nconc (cdr arg) into output
- else
- nconc arg into args
- finally (return (values actions callbacks args output)))
- `(js:with-unique-js-names (js-callbacks)
- `(progn
- (setf ,js-callbacks (array))
- ,,@(loop for c in callbacks
- for i upfrom 0
- collect
- ``(setf (aref ,js-callbacks ,,i)
- (lambda () ,,(third c))))
- (dojo.io.bind
- (create
- ,@(unless
- ,(getf args :url)
- `(:url
- ,(lol::make-action-url
- ,component
- (progn
- ,@actions))))
- ,@ (unless
- ,(getf args :post-content)
- `(:post-content (+ ,,@(loop for c in callbacks
- for n upfrom 0
- nconc `((ucw::make-new-callback
-
- (lambda (,(car c))
- ,(second c)))
- "="
- `(encode-u-r-i-component ((aref ,js-callbacks ,,n)))
- "&")))))
- ,@ (unless
- ,(or (getf args :load) (not output) )
- `(:load
- (lambda (evt data)
- (setf (slot-value (document.get-element-by-id ,,@output) inner-h-t-m-l) data))))
- ,,:method "post"
- ,,@args))))))
-
-
-
-
-
-;;;; ** Editor
-
-(defcomponent dojo-editor (dojo-component dojo-input-component-mixin)
- ((document :accessor document :initarg :document :initform "test"))
- (:default-initargs
- :requires '("dojo.event.*" "dojo.widget.Editor" "dojo.io.*" "dojo.widget.RichText")))
-
-(defmethod save-document ((self dojo-editor))
- t)
-
-(defmethod js-on-load ((self dojo-editor))
- `(lambda (x)
- (setf document.location
- ,(lol::make-action-url
- self
- (answer self)))))
-
-(defmethod render-editor ((self dojo-editor))
- (<ucw:script
- `(dojo.add-on-load
- (lambda ()
- (setf div (document.get-element-by-id ,(input-id self)))
- (setf editor (dojo.widget.from-script
- "Editor"
- (create) div))
- (setf save
- (create
- :save-to-server
- (lambda ()
- (dojo.io.bind
- (create
- :method "post"
- :post-content (+
- ,(ucw::make-new-callback
-
- (lambda (x)
- (setf (document self) x)))
- "="
- (encode-u-r-i-component (editor.get-html)))
- :url
- ,(lol::make-action-url
- self
- (save-document self))
-
- :load ,(js-on-load self))))))
- (dojo.event.kw-connect
- (create :type "before"
- :src-obj editor
- :src-func "onSave"
- :target-obj save
- :target-func "saveToServer")))))
- (<:div :class "editor"
- (<:div
- :id (input-id self)
- (<:as-is (document self)))))
-
-(defmethod render ((self dojo-editor))
- (render-editor self))
-
-(defcomponent dojo-editor-presentation (dojo-editor mewa::mewa-editor)
- ())
-
-(lol::defslot-presentation dojo-editor-slot-presentation (dojo-editor mewa::mewa-string-slot-presentation)
- ((document :accessor document :initarg :document)
- (instance :accessor instance))
- (:type-name dojo-editor))
-
-(defmethod save-document ((self dojo-editor-slot-presentation))
- (setf (lol::presentation-slot-value self (instance self)) (document self)))
-
-(defmethod lol::present-slot ((slot dojo-editor-slot-presentation) instance)
- (setf (document slot) (lol::presentation-slot-value slot instance))
- (setf (instance slot) instance)
- (render-requires slot)
- (render-editor slot))
-
-(defmethod js-on-load ((self dojo-editor-slot-presentation))
- `(lambda (x)
- (setf document.location
- ,(lol::make-action-url
- self
- (answer-component (ucw::parent self) self)))))
-
-
-(defcomponent sortable-list-editor (lol::mewa-list-presentation
- dojo-component
- dojo-input-component-mixin
- dojo-output-component-mixin)
- ()
- (:default-initargs
- :requires '("dojo.event.*" "dojo.dnd.*" "dojo.io.*")))
-
-(defmethod present-output ((self sortable-list-editor))
- (loop for li in (mewa::instances self)
- for n upfrom 0
- do
- (let ((li li))
- (<:li :id (format nil "~A~A" (input-id self) n)
- (<:as-html (lol:present-view (li :one-line)))
- (<:br)
- (<ucw:a :action (lol:call-view (li :editor (call-from self)))
- (<:as-html "(edit)"))
- (<ucw:a :action (lol:call-view (li :editor))
- (<:as-html "(remove)"))))))
-
-(defmethod lol::present ((self sortable-list-editor))
- (<:div (<:as-html "Drag and Drop list items to change the order"))
- (<:ul
- :id (input-id self)
- (present-output self))
- (<:ul (<:li
- (<ucw:a :action (answer (mewa::instances self))
- (<:as-html "*Save*")))
-
- (<:li
- (<ucw:a :action (add-list-item self)
- (<:as-html "*Add Item*")))
- (<:li
- (<ucw:a :action (answer nil)
- (<:as-html "*Cancel*"))))
-
- (<ucw:script
- ;;;; The Dojo example :
- ;;;; var dl = byId("dragList3");
- ;;;; new dojo.dnd.HtmlDropTarget(dl, ["li2"]);
- ;;;; var lis = dl.getElementsByTagName("li");
- ;;;; for(var x=0; x<lis.length; x++){
- ;;;; new dojo.dnd.HtmlDragSource(lis[x], "li2");}
-
- ;;;; and the parenscript
- `(dojo.event.connect dojo "loaded"
- (lambda ()
- (setf make-sortable
- (lambda (x)
- (setf ulist (document.get-element-by-id x))
- (setf drop (new (dojo.dnd.*html-drop-target ulist (array x))))
- (setf list-items (ulist.get-elements-by-tag-name "li" ))
- (dolist (li list-items)
- (new (dojo.dnd.*html-drag-source li x)))))
- (make-sortable ,(input-id self))
-
- (dojo.event.connect
- drop "onDrop"
- (lambda ()
- (dolist (li list-items)
- (new (dojo.dnd.*html-drag-source li ,(input-id self))))
- ,
- (with-ajax (self)
- (:action nil)
- (:callback d (let ((list-order
- (mapcar #'(lambda (x)
- (parse-integer (subseq x (length (input-id self)))))
- (read-from-string d))))
- (setf (mewa::instances self) (reorder-list (mewa::instances self) list-order)))
- `(progn
- (setf my-list "(")
- (dolist (li list-items)
- (setf my-list (+ my-list "\"" li.id "\"" " ")))
- (setf my-list (+ my-list ")"))
- (return my-list)))
- (:load `(lambda (x data)
- (setf (slot-value (document.get-element-by-id ,(input-id self)) inner-h-t-m-l) data)
- (make-sortable ,(input-id self)))))))))))
-
-
-;(defcomponent dojo-combo-box )
\ No newline at end of file
+++ /dev/null
-(in-package :mewa)
-
-
-(defgeneric make-range-list-generator (instance &key query chunk-size &allow-other-keys)
- (:documentation "Produced generator must obeys the following interface:
-GENERATOR (:first|:last|:next|:previous|:current &optional offset) =>
- (ITEMS LIST)
-GENERATOR :offset &optional (offset integer) => (new-offset integer)
-GENERATOR :chunk-size (size integer) => (new-chunk-size integer)
-GENERATOR :chunks => (total-number-of-chunks integer)
-GENERATOR (:have-previous-p|:have-next-p) => (v boolean)."))
-
-(defmethod make-range-list-generator ((instance clsql:standard-db-object) &key query (chunk-size 20) (offset 0))
- (let ((view-class (class-of instance))
- (current-offset offset)
- (last-select-size 0))
- (labels ((guess-total-size ()
- (car
- (apply #'clsql:select
- (clsql:sql-count (clsql:sql-expression :attribute '*))
- :from (clsql:sql-expression :table (slot-value view-class 'clsql:view-table))
- (append query '(:flatp t)))))
- (select-items (offset size)
- (apply #'clsql:select (class-name view-class)
- (append query
- `(:limit ,(+ size 1) :offset ,(* (- offset 1) size) :flatp t))))
- (chunks ()
- (multiple-value-bind (q rem)
- (floor (guess-total-size) chunk-size)
- (if (zerop rem) q (+ q 1)))))
- (lambda (cmd &optional num)
- (setf current-offset
- (case cmd
- (:first 1)
- (:last (chunks))
- (:next (+ 1 current-offset))
- (:previous (max 1 (- current-offset 1)))
- ((:current :offset) (if num (max 1 num) current-offset))
- (otherwise current-offset)))
- (ecase cmd
- ((:first :last :next :previous :current)
- (let ((items (select-items current-offset chunk-size)))
- (setf last-select-size (length items))
- (when (> last-select-size chunk-size)
- (nbutlast items))
- items))
- (:chunks (chunks))
- (:chunk-size (when num (setf chunk-size num))
- chunk-size)
- (:offset current-offset)
- (:have-previous-p (> current-offset 1))
- (:have-next-p (> last-select-size chunk-size)))))))
-
-(defcomponent range-list (mewa::mewa-list-presentation)
- ((offset :accessor range-list.offset
- :initform 0
- :backtrack t
- :documentation "Which of the windows we're currently looking at.")
- (window-size :accessor range-list.window-size :initform 20 :initarg :window-size)
- (generator :reader range-list.generator)
- (generator-args :reader range-list.generator-args :initarg generator-args :initform nil))
- (:documentation "Component for showing the user a set of data one \"window\" at a time.
-
-The data set is presented one \"window\" at a time with links to
-the the first, previous, next and last window. Each window shows
-at most WINDOW-SIZE elements of the data.
-The GENERATOR is used to get a data to display every time.
-It is produced by MAKE-RANGE-LIST-GENERATOR as
-MAKE-RANGE-LIST-GENERATOR INSTANCE :chunk-size WINDOW-SIZE GENERATOR-ARGS"))
-
-(defmethod range-list.generator :before ((self range-list))
- (unless (slot-boundp self 'generator)
- (create-generator self)))
-
-(defmethod create-generator ((self range-list) &rest args)
- (with-slots (instance generator generator-args window-size offset)
- self
- (when args
- (setf generator-args args))
- (setf generator
- (apply 'make-range-list-generator instance :chunk-size window-size generator-args)
- offset 0)
- (funcall generator :offset offset)))
-
-(defmethod range-list.have-previous-p ((self range-list))
- "Returns true if we have a window before the current one."
- (funcall (range-list.generator self) :have-previous-p))
-
-(defmethod range-list.have-next-p ((self range-list))
- "Returns true if we have a window after the current one."
- (funcall (range-list.generator self) :have-next-p))
-
-(defmethod range-list.fetch-items ((self range-list) op)
- (prog2
- (ecase op ((:first :last :current :next :previous) t))
- (funcall (range-list.generator self) op)
- (setf (range-list.offset self)
- (funcall (range-list.generator self) :offset))))
-
-(defmethod/cc scroll ((self range-list) op)
- (funcall (range-list.generator self) :offset (range-list.offset self))
- (setf (mewa::instances self)
- (range-list.fetch-items self op)))
-
-(defmethod/cc scroll-to-page ((self range-list) window-number)
- (setf (range-list.offset self) window-number)
- (scroll self :current))
-
-(defmethod present ((self range-list))
- (when (zerop (range-list.offset self))
- (scroll self :current))
- (<:table :class (css-class self)
- (<:tr
- (<:td (call-next-method)))
- (<:tr
- (<:td
- (<:table :class "range-list-navigation"
- (<:tr
- (<:td
- (<ucw:a :action (scroll self :first)
- (<:tt (<:as-html "<<"))))
- (<:td
- (if (range-list.have-previous-p self)
- (<ucw:a :action (scroll self :previous)
- (<:tt (<:as-html "<")))
- (<:tt (<:as-html "<"))))
- (<:td
- (if (range-list.have-next-p self)
- (<ucw:a :action (scroll self :next)
- (<:tt (<:as-html ">")))
- (<:tt (<:as-html ">"))))
- (<:td
- (<ucw:a :action (scroll self :last)
- (<:tt (<:as-html ">>"))))))))))
+++ /dev/null
-(in-package :lisp-on-lines)
-
-
-(defmethod simple-word-search (class-name slots search-terms)
- (select class-name
- :where (simple-word-search-where class-name slots search-terms)
- :flatp t))
-
-(defmethod simple-word-search-where (class-name slots search-terms)
- (sql-or
- (mapcar #'(lambda (term)
- (apply #'sql-or
- (mapcar #'(lambda (slot)
- (sql-uplike
- (sql-slot-value class-name slot)
- (format nil "%~a%" term)))
- slots)))
- search-terms)))
-
-(defmethod find-slots-of-type (model &key (type 'string)
- (types '((string)) types-supplied-p))
- "returns a list of slots matching TYPE, or matching any of TYPES"
- (let (ty)
- (if types-supplied-p
- (setf ty types)
- (setf ty (list type)))
- (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
- (first st)))
- (list-slot-types model)))))
-
-;;;; * Simple Search Component
-
-(defcomponent simple-search ()
- ((search-term :initarg :search-term :accessor search-term :initform "")
- (listing :initarg :listing :accessor listing :initform :listing)
- (select-returns-p :initarg :select-returns-p :accessor select-returns-p :initform nil)
- (search-tables :initarg :search-tables :accessor search-tables :initform nil)))
-
-(defmethod render-on ((res response)(self simple-search))
- (<ucw:input :type "text" :accessor (search-term self))
- (<ucw:submit :action (do-search self)))
-
-(defmethod perform-simple-search ((self simple-search) &key (base-classes (meta-model:list-base-classes :clsql)))
- (when (search-tables self)
- (setf base-classes (search-tables self)))
- (remove nil (mapcar #'(lambda (x)
- (simple-word-search x
- (find-slots-of-type x)
- (split-sequence #\Space (search-term self))))
- base-classes)))
-
-
-(defmethod/cc do-search ((self simple-search))
- (let* ((target (or (slot-value self 'ucw::parent) self))
- (result (call-component
- target
- (make-instance 'simple-search-results
- :listing (listing self)
- :results
- (perform-simple-search self :base-classes
- (remove 'claim-history (meta-model:list-base-classes :clsql)))
- :search-term (split-sequence #\Space (search-term self))))))
- (when result
- (if (select-returns-p self)
- (answer result)
- (call-component target (make-presentation result :type :viewer))))))
-
-(defcomponent simple-search-results ()
- ((results :accessor results :initarg :results :initform nil)
- (listing :initarg :listing :accessor listing :initform :listing)
- (search-term :initarg :search-term :accessor search-term :initform nil)))
-
-(defmethod view-name (view)
- (class-name (class-of view)))
-
-(defmethod render-on ((res response) (self simple-search-results))
- (<:h3 (<:as-html "Search results for " (search-term self)))
- (dolist (r (results self))
- (<:fieldset
- (<:legend (<:as-html (format nil "Found ~A results in ~A:" (length r) (view-name (car r)))))
- (render-on res
- (embed-component
- self
- (make-presentation
- (car r)
- :type :listing
- :initargs `(:instances ,r)))))))
-
-(defmethod/cc ok ((self simple-search-results) &optional arg)
- (declare (ignore arg))
- (answer nil))
-
-
-
-;;;; * Advanced Search Component
-
-(defcomponent advanced-search ()
- ((simple-search :component simple-search :accessor simple-search)
- (search-table :accessor search-table :initform nil)
- (search-presentation :accessor search-presentation :initform nil)))
-
-(defmethod render-on ((res response) (self advanced-search))
- (<:h2 (<:as-html "Advanced Search"))
- ;; simple search :
- (<:fieldset
- (<:legend (<:as-html "simple text search"))
- (render-on res (simple-search self)))
- ;; complex-search
- (<:fieldset
- (<:legend (<:as-html "Complex Search"))
- (<:as-html "Choose search table:")
- (<ucw:select
- :accessor (search-table self)
- (dolist (tbl (meta-model:list-base-classes :clsql))
- (<ucw:option :value tbl (<:as-html tbl))))
- (<ucw:submit :action (select-search-table self) :value "select")
- ;;
- (when (search-presentation self)
- (<:fieldset
- (<:legend (<:as-html (format nil "search ~A" (search-table self))))
- (render-on res (embed-component self (search-presentation self)))))))
-
-
-(defun make-search-presentation (instance )
- (make-instance 'mewa::mewa-presentation-search
- :search-presentation (make-presentation instance :type :search-model)
- :list-presentation (make-presentation instance :type :listing
-(defmethod/cc select-search-table ((self advanced-search))
- (let* ((i (make-instance (search-table self)))
- (p (make-search-presentation i)))
- (embed-component self p)
- (setf (search-presentation self) p) ))
-
-
-(defcomponent table-search
-
-
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defmacro defdescription (name super-descriptions attributes &rest arguments)
- "Create a description and any lines specified."
- ;; Remove any existing lines
- `(progn
- (dolist (method (remove-if
- (lambda (method)
- (when (eql (contextl::get-layered-function-definer-name 'line-in)
- (closer-mop:generic-function-name
- (closer-mop:method-generic-function method)))))
- (closer-mop:specializer-direct-methods (find-class ',name))))
- (remove-method (symbol-function (contextl::get-layered-function-definer-name 'line-in))
- method))
- ;; Create any attributes
- (let ((occurence (find-occurence ',name)))
- (initialize-occurence-for-instance occurence (make-instance ',name))
- ,@(mapcar #'(lambda (x)
- `(ensure-attribute occurence :name ',(car x) ,@(cdr x)))
- attributes)
- ;; Add any layered lines specified.
- ,@(when t #+ (or) (ignore-errors (find-class name))
- (loop for arg in arguments
- when (eql (car arg) :in-layer)
- collect `(defline line-in ((self ,name) :in-layer ,(second arg))
- (list ,@(cddr arg))))))))
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(define-layered-function display-using-description (description object component)
- (:method-combination wrapping-standard)
- (:documentation
- "Render the object in component,
- using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
-
-(defun make-display-function (component object
- &rest properties
- &key (line #'line-in)
- &allow-other-keys)
- "returns a function that expects a 3 argument function as its argument
-
-The function argument (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
-
- (lambda (function)
- (let* ((description (find-occurence object)))
- (if description
- (dletf (((attributes description)
- (or
- (attributes description)
- (list-attributes description))))
- ;; apply the default line to the description
- (funcall-with-description
- description
- (funcall line object)
- ;; apply the passed in arguments and call display-using-description
- #'(lambda ()
- (funcall-with-description
- description
- properties
- function description object component))))
- (error "no description for ~A" object)))))
-
-(define-layered-function display (component object &rest args)
- (:documentation
- "Displays OBJECT in COMPONENT."))
-
-(define-layered-method display ((component t) (object t)
- &rest properties)
- " The default display dispatch method
-
- DISPLAY takes two required arguments,
- COMPONENT : The component to display FROM (not neccesarily 'in')
- OBJECT : The 'thing' we want to display... in this case it's the component
-
- DISPLAY also takes keywords arguments which modify the DESCRIPTION,
- that is to say the parameters that come together to create the output.
-
-The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
- (funcall (apply 'make-display-function component object properties)
- 'display-using-description))
-
-;;;;; Macros
-
-(defun funcall-with-layers (layers thunk)
- (let ((context (current-layer-context)))
- (loop :for (op layer)
- :on layers :by #'cddr
- :do (setf context
- (case op
- (+ (adjoin-layer layer context))
- (- (remove-layer layer context)))))
- (funcall-with-layer-context context thunk)))
-
-
-(defun funcall-with-description (description properties function &rest args)
- (if description
- (dletf* (((description-type description)
- (or
- (getf properties :type)
- (description-type description)))
-
- ((description-layers description)
- (append
- (description-layers description)
- (getf properties :layers)))
- ((description-properties description) (append (description-properties description) properties)))
- (funcall-with-layers
- (description-layers description)
- (lambda ()
- (contextl::funcall-with-special-initargs
- (list (cons description properties))
- #'(lambda ()
- (apply function args))))))
- (apply function args)))
-
-(defmacro with-description ((description &rest properties) &body body)
- `(funcall-with-description ,description (if ',(cdr properties)
- (list ,@properties)
- ,(car properties))
- #'(lambda ()
- ,@body)))
-
-(define-layered-function find-do-attributes (desc))
-
-(define-layered-method find-do-attributes ((description description))
-
- (loop
- :for att
- :in (attributes description)
- :collect (let ((default (find (car (ensure-list att))
- (default-attributes description)
- :key #'car)))
- (or default att))))
-
-(defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
- (with-unique-names (att properties type)
- `(dolist* (,att ,attributes)
- (let* ((,att (ensure-list ,att))
- (,properties (rest ,att))
- (,type (getf ,properties :type))
- (,var (let ((a (find-attribute ,description (first ,att))))
- (if ,type
- (apply #'make-attribute :name (first ,att) :type ,type ,properties)
- (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
- (funcall-with-description ,var ,properties
- #'(lambda ()
- ,@body))))))
-
-(defmacro with-component ((component) &body body)
- `(let ((self ,component))
- (declare (ignorable self))
- (flet ((display* (thing &rest args)
- (apply #'display ,component thing args))
- (display-attribute (attribute obj &rest
- props)
- (if props
- (funcall-with-description
- attribute props
- #'display-using-description attribute obj ,component)
- (display-using-description attribute obj ,component))))
- (declare (ignorable #'display* #'display-attribute))
- ,@body)))
-
-
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(define-layered-function line-in (name)
- (:method-combination append)
- (:method append (thing)
- '()))
-
-(defmacro defline (name (specializer &rest layers-and-combination-keywords) &body docstring-and-body)
- `(progn
- (define-layered-method
- ,name
- ,@layers-and-combination-keywords
- ,@(unless
- (or (third layers-and-combination-keywords)
- (and layers-and-combination-keywords
- (null (cdr layers-and-combination-keywords))))
- '(APPEND))
- (,specializer)
- ,(when (cdr docstring-and-body)
- (car docstring-and-body))
-
- ,(or (cdr docstring-and-body) (car docstring-and-body)))))
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; *LoL Entry points
-;;;;
-
-;;;; This file contains the high level functions and macros
-;;;; that are part of LoL proper, that is to say, not Mewa
-;;;; or Meta-Model.
-
-
-
-(defmacro action (args &body body)
- `(lambda ,args
- (with-call/cc
- ,@body)))
-
-;;;; ** Initialisation
-(defmethod find-default-attributes ((object t))
- "return the default attributes for a given object using the meta-model's meta-data"
- (append (mapcar #'(lambda (s)
- (cons (car s)
- (gen-pslot
- (if (meta-model:foreign-key-p object (car s))
- 'foreign-key
- (cadr s))
- (string (car s)) (car s))))
- (meta-model:list-slot-types object))
- (mapcar #'(lambda (s)
- (cons s (append (gen-pslot 'has-many (string s) s)
- `(:presentation
- (make-presentation
- ,object
- :type :one-line)))))
- (meta-model:list-has-many object))
- (find-default-presentation-attribute-definitions)))
-
-(defmethod set-default-attributes ((object t))
- "Set the default attributes for MODEL"
- (clear-attributes object)
- (mapcar #'(lambda (x)
- (setf (find-attribute object (car x)) (cdr x)))
- (find-default-attributes object)))
-
-;;;; This automagically initialises any meta model
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmethod meta-model::generate-base-class-expander :after (meta-model name args)
- (set-default-attributes name)))
-
-;;;; The following macros are used to initialise a set of database tables as LoL objects.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun generate-define-view-for-table (table)
- "
-Generates a form that, when evaluated, initialises the given table as an lol object.
-This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation"
-
- `(progn
- (rofl::gen-view-class ,table :generate-joins :all)
- (set-default-attributes (quote ,(meta-model::sql->sym table))))))
-
-(defmacro define-view-for-table (&rest tables)
- " expand to a form which initialises TABLES for use with LOL"
- `(progn
- ,@(loop for tbl in tables collect (generate-define-view-for-table tbl))
- (values)))
-
-(defmacro define-views-for-database ()
- "expands to init-i-f-t using the listing of tables provided by meta-model"
- `(define-view-for-table ,@(meta-model::list-tables)))
-
-
-(defmethod find-slots-of-type (model &key (type 'string)
- (types '((string)) types-supplied-p))
- "returns a list of slots matching TYPE, or matching any of TYPES"
- (let (ty)
- (if types-supplied-p
- (setf ty types)
- (setf ty (list type)))
- (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
- (first st)))
- (lisp-on-lines::list-slot-types model)))))
-
-
-
-
-
-
-(defmethod word-search (class-name slots search-terms
- &key (limit 10) (where (sql-and t)))
- (select class-name
- :where (sql-and
- where
- (word-search-where class-name slots search-terms :format-string "~a%"))
- :flatp t
- :limit limit))
-
-
-(defmethod word-search (class-name slots (s string) &rest args)
- (apply #'word-search class-name slots (list s) args))
-
-(defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%"))
- (sql-or
- (mapcar #'(lambda (term)
- (apply #'sql-or
- (mapcar #'(lambda (slot)
- (sql-uplike
- (sql-slot-value class-name slot)
- (format nil format-string term)))
- slots)))
- search-terms)))
-
-
-
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-
-
-
-;;;; PLIST Utilities.
-
-(defun plist-nunion (new-props plist)
- "Destructive Merge of plists. PLIST is modified and returned.
-NEW-PROPS is merged into PLIST such that any properties
-in both PLIST and NEW-PROPS get the value in NEW-PROPS.
-The other properties in PLIST are left untouched."
- (loop for cons on new-props by #'cddr
- do (setf (getf plist (first cons)) (second cons))
- finally (return plist))
- plist)
-
-(defun plist-union (new-props plist)
- "Non-destructive version of plist-nunion"
- (plist-nunion new-props (copy-list plist)))
-
-
-
-
-
-
-(defun slots-as-properties (object)
- "Makes a plist by making a keyword from the ...ahh .. read the damn code"
- (mapcan
- #'(lambda (slot-name)
- (when (slot-boundp object slot-name)
-
- (list (intern (symbol-name slot-name)
- (find-package :keyword))
- (slot-value object slot-name))))
- (list-slots object)))
-
-(defun properties-as-slots (plist)
- "takes a plist and turns it into slot-definitions, interning the key names in *package*"
- (loop for (key val) on plist by #'cddr
- collect (let ((name (intern (symbol-name key))))
- `(,name :accessor ,name :initarg ,key :special t :initform ,val))))
-
-(defmacro with-properties ((properties &optional (prefix '||)) &body body)
- (with-unique-names (p)
- (let ((get (intern (strcat prefix '.get)))
- (set (intern (strcat prefix '.set)))
- (props (intern (strcat prefix '.properties))))
- `(let ((,p ,properties))
- (flet ((,get (p)
- (getf ,p p))
- (,set (p v)
- (setf (getf ,p p) v))
- (,props ()
- ,p))
- (declare (ignorable #',get #',set #',props))
- ,@body)))))
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defmethod initargs.slot-names (object)
- "Returns ALIST of (initargs) . slot-name."
- (nreverse (mapcar #'(lambda (slot)
- (cons (closer-mop:slot-definition-initargs slot)
- (closer-mop:slot-definition-name slot)))
- (closer-mop:class-slots (class-of object)))))
-
-(defun find-slot-names-from-initargs-plist (object initargs-plist)
- "returns (VALUES SLOT-NAMES VALUES), Given a plist of initargs such as one would pass to :DEFAULT-INITARGS.
-SLOT-NAMES contains the slot-names specified by the initarg, and VALUES the corresponding VALUE."
- (let (slot-names values
- (initargs.slot-names-alist (initargs.slot-names object)))
- (loop for (initarg value) on initargs-plist
- do (let ((slot-name
- (cdr (assoc-if #'(lambda (x) (member initarg x))
- initargs.slot-names-alist))))
- (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
- (push slot-name slot-names)
- (push value values)))
- finally (return (values slot-names values)))))
-
-(defun funcall-with-special-initargs (object initargs function &rest args)
- "Call FUNCTION with dynnamic bindings of the slots in OBJECT specified by the INITARGS plist"
- (multiple-value-bind (slot-names values)
- (find-slot-names-from-initargs-plist object initargs)
- (special-symbol-progv
- (with-symbol-access
- (loop for slot-name in slot-names
- collect (slot-value object slot-name)))
- values
- (apply function args))))
-
-(defmacro with-special-initargs ((object &rest initargs) &body body)
- `(funcall-with-special-initargs ,object ,initargs
- #'(lambda ()
- ,@body)))
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(deflayer lisp-on-lines ())
-
-;;;; The Standard Layers
-(deflayer viewer (lisp-on-lines))
-(deflayer editor (lisp-on-lines))
-
-;;;; Attributes
-(defdisplay
- :in-layer editor
- ((attribute standard-attribute) object)
- (call-next-method))
-
-(defdisplay
- ((attribute standard-attribute) object component)
- (<:as-html (attribute-value object attribute)))
-
-(define-layered-method display-using-description
- ((attribute standard-attribute) object component)
- (with-component (component)
- )
- (<:as-html (attribute-value object attribute)))
-
-(define-layered-method label (anything)
- nil)
-
-(defdisplay
- :in-layer editor :around (description object)
- "It is useful to remove the viewer layer when in the editing layer.
-This allows us to dispatch to a subclasses editor.
-"
- (with-inactive-layers (viewer)
- (call-next-method)))
-
-;;;; These layers affect the layout of the object
-(deflayer one-line)
-(deflayer as-table)
-(deflayer as-string)
-
-(defdisplay
- :in-layer as-string (d o (self t))
- (with-output-to-string (yaclml::*yaclml-stream*)
- (do-attributes (a d)
- (display-attribute a o)
- (<:as-html " "))
- #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
-)))
-
-
-(defdisplay
- :in-layer as-string (d o)
- (with-output-to-string (yaclml::*yaclml-stream*)
- (do-attributes (a d)
- (display-attribute a o)
- (<:as-html " "))
- #+nil (with-inactive-layers (editor viewer one-line as-table show-attribute-labels)
-)))
-
-(defmethod list-slots (thing)
- (list 'identity))
-
-;;;; * Object displays.
-
-
-
-;;;; TODO: all lisp types should have occurences and attributes defined for them.
-
-(defdisplay ((description t) lisp-value)
- (<:as-html lisp-value))
-
-(defdisplay (description (object string))
- (<:as-html object))
-
-(defdisplay (description (object symbol))
- (<:as-html object))
-
-(defdisplay (description object (component t))
- "The default display for CLOS objects"
- (print (class-name (class-of object)))
- (dolist* (slot-name (list-slots object))
- (let ((boundp (slot-boundp object slot-name)))
- (format t "~A~A : ~A" (strcat slot-name)
- (if boundp
- ""
- "(unbound)")
- (if boundp
- (slot-value object slot-name) "")))))
-
-(defdisplay ((description t) object)
- "The default display for CLOS objects in UCW components"
- (dolist* (slot-name (list-slots object))
-
- (let ((boundp (slot-boundp object slot-name)))
- (<:label :class "lol-label"
- (display-attribute 'label (strcat slot-name))
- (if boundp
- ""
- "(unbound)"))
- (<:as-html
- (if boundp
- (slot-value object slot-name) "")))))
-
-;;;; ** The default displays for objects with a MEWA occurence
-
-(defdisplay (description object)
- (<:div
- :class "lol-display"
- (when (label description)
- (<:span
- :class "title"
- (<:as-html (label description))))
- (do-attributes (attribute description)
- (<:div
- :class "attribute"
- (display-attribute attribute object)))))
-
-;;;; ** One line
-(defdisplay
- :in-layer one-line (description object)
- "The one line presentation just displays the attributes with a #\Space between them"
- (do-attributes (attribute description)
- (display-attribute attribute object)
- (<:as-html " ")))
-
-;;;; ** as-table
-
-(defdisplay :in-layer as-table (description object)
- (<:table
- (do-attributes (a description)
- (<:tr
- (<:td :class "lol-label" (<:as-html (label a)))
- (<:td (display-attribute a object))))))
-
-;;;; List Displays
-
-#| (deflayer list-display-layer)
-
-(define-layered-class description
- :in-layer list-display-layer ()
- ((list-item :initarg :list-item
- :initarg :table-item
- :initform nil
- :special t
- :accessor list-item)))
-
-(defdisplay (desc (list list))
- (with-active-layers (list-display-layer)
- (<:ul
- (dolist* (item list)
- (<:li (apply #'display* item (list-item desc)))))))
-
-(defdisplay :in-layer as-table (description (list list))
- (with-active-layers (list-display-layer)
- (let ((item-description (find-occurence (first list))))
- (<:table
- (funcall
- (apply #'lol::make-display-function self (first list)
- (list-item description))
- (lambda (desc item component)
- (<:tr
- (do-attributes (a desc)
- (<:th (<:as-html (label a)))))
-
- (dolist* (obj list)
- (<:tr
- (do-attributes (a desc)
- (<:td (display-attribute a obj))))))))))) |#
-
-
-
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defclass standard-occurence-class (standard-class)
- )
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; STRINGS
-
-(find-or-create-occurence 'string)
-
-(defmethod find-occurence ((string string))
- (find-occurence 'string))
-
-(set-attribute 'string 'identity `(string :getter ,#'(lambda (x)
- (identity x))))
-(set-default-attributes 'string)
-
-;;;; LISTS
-
-(find-or-create-occurence 'list)
-
-(defmethod find-occurence ((list list))
- (find-occurence 'list))
-
-(set-attribute 'list 'identity `(string :getter ,#'(lambda (x)
- (identity x))))
-(set-default-attributes 'string)
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;;; Wrap a display in "back buttons"
-(deflayer wrap-back-buttons)
-
-(defvar *back-buttons-wrapped-p* nil)
-
-(defdisplay
- :in-layer wrap-back-buttons :around
- (description object)
- (if *back-buttons-wrapped-p*
- (call-next-method)
- (let ((*back-buttons-wrapped-p* t))
-
- (<ucw:a :class "wiz-button previous" :action (ok self t)
- (<:as-html "Go Back"))
- (<:div :style "clear:both;"
- (call-next-method))
- (<ucw:a :class "wiz-button previous" :action (ok self t)
- (<:as-html "Go Back")))))
-
-;;;; Wrap an object display in with a link to the object
-
-(deflayer wrap-link)
-
-(defvar *link-wrapped-p* nil)
-
-#+nil(define-layered-class description
- :in-layer wrap-link ()
- ((link :initarg :link-action
- :initarg :action
- :initform nil :special t :accessor link-action)))
-
-(defmethod/cc call-action-with-component-and-object ((self component) action-id object)
- (funcall (ucw::find-action (ucw::context.current-frame *context*) action-id)
- self
- object))
-
-(defdisplay
- :in-layer wrap-link :around (description object)
- (let ((link (link-action description)))
-
- (with-inactive-layers (wrap-link)
- (if *link-wrapped-p*
- (call-next-method)
- (let ((*link-wrapped-p* t))
- (<ucw:a :action (call-action-with-component-and-object
- self
- (ucw::make-new-action
- (ucw::context.current-frame *context*)
- (if (consp link)
- (eval link)
- link))
- object)
- (call-next-method)))))))
-
-;;; wrap-a-form
-(deflayer wrap-form)
-
-(defvar *in-form-p* nil)
-
-#+nil(define-layered-class description
- :in-layer wrap-form ()
- ((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)
- (form-type :initarg :form-type :initform '<ucw:simple-form :special t :accessor form-type)))
-
-(defattribute form-button-attribute ()
- ((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)))
-
-(defdisplay ((description form-button-attribute) object)
- (macrolet ((submit (&key action value )
- `(<ucw::value-submit
- :action (funcall ,action self object)
-
- :value ,value)))
- (loop for button in (form-buttons description)
- do
- (let ((button button))
- (with-properties (button)
- (let ((action (.get :action)))
- (submit :value (.get :value)
- :action (if (consp action)
- (eval action)
- action))))))))
-
-
-(defdisplay
- :in-layer wrap-form
- :around (description object)
- (flet ((body ()
- (with-inactive-layers (wrap-form)
- (call-next-method)
- (with-inactive-layers (show-attribute-labels)
- (display-attribute
- (make-instance
- 'form-button-attribute
- :form-buttons
- (form-buttons description))
- object)))))
- (ecase (form-type description)
- ('<ucw:simple-form
- (<ucw:simple-form
- :action (refresh-component self)
- (body)))
- ('<ucw:form
- (<ucw:form
- :action (refresh-component self)
- (body))))))
-
-;;;; wrap a DIV
-
-
-(deflayer wrap-div)
-
-#+nil(define-layered-class description
- :in-layer wrap-div ()
- ((div-attributes :accessor div-attributes :initarg :div :special t :initform nil)))
-
-(defdisplay :in-layer wrap-div :wrap-around (description object)
- (let ((args (div-attributes description)))
- (with-inactive-layers (wrap-div)
- (yaclml::funcall-with-tag
- (cons '<:div args)
- (lambda ()
- (call-next-method))))))
-
-
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; LoL CLOS Tests
-;;;;
-(defclass lol-test-class ()
- ((test-slot-value :initform "slot-value")
- (test-string :initform "Test String"))
- (:documentation "foo"))
-
-(defvar *foo* nil)
-
-(defvar *standard-layers* '(viewer editor creator one-line as-string))
-
-(define-attributes (lol-test-class)
- (test-getter t
- :label "Getter"
- :getter (constantly "Hello World"))
- (test-getter/setter t
- :label "Getter/Setter:"
- :getter (lambda ()
- *foo*)
- :setter #'(lambda (value)
- (setf *foo* value)))
- (test-slot-value t)
- (test-string string :label "String" :documentation))
-
-(defcomponent test-component ()
- (current-layer :accessor current-type :initform 'viewer)
- (layer-spec :accessor layer-spec :initform nil)
- (instance :accessor instance :initform (make-instance 'test-class))))
-
-(defmethod render ((self test-component))
- (let ((test (instance self)))
- (<:h1 (<:as-html "Lisp on Lines Test Component"))
- (with-component (self)
- (<ucw:form
- :action (refresh-component self)
- (<ucw:select :accessor (current-layer self)
- (dolist* (type (display-types self))
- (<ucw:option :value type (<:as-html type))))
- (<:input :type "Submit" :value "update")
- (<:fieldset
- (<:legend (<:as-html (current-type self)))
- (display test :type (current-type self)))))))
-
-
-(defcomponent standard-display-component ()
- ((display-function :accessor display-function :initarg :display)))
-
-(defmethod render ((self standard-display-component))
- (funcall (display-function self) self))
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / commitdiff