Commit 637b8bed authored by Dave Cooper's avatar Dave Cooper

first set of patches for 1588

parent bd958423
(in-package :gwl)
(defparameter *1588p001-doc*
"Makes the respondent default to the bashee for base-html-sheet, same as for base-ajax-sheet.")
(define-object-amendment base-html-sheet ()
:input-slots
((respondent (the bashee))))
(format t "~&~%Changes in 1588p001:~%~%~a~%~%" *1588p001-doc*)
(in-package :gdl)
(defparameter *1588p002-doc*
"On Update!, pulls version-tree for true root down to
root-object-object, if the root-object-object is a child of the true
root and has its root set to itself. This is the case for the object
being inspected in ta2 and tasty, for example. This makes (the
update!) work as expected for the root-object-object of tasty or
ta2, even though the actual version-tree is stored at the
parent (i.e. at the true root).
NOTE: This patch is superseded by p004.")
(define-object-amendment vanilla-mixin* ()
:functions
(("Void. Uncaches all cached data in slots and objects throughout the instance
tree from this node, forcing all code to run again the next time values are
demanded. This is useful for updating an existing model or part of an existing
model after making changes and recompiling/reloading the code of the underlying
definitions. Any set (modified) slot values will, however, be preserved
by the update."
update!
(&key (replace-bashed-values? t))
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object))
;;
;; FLAG -- get rid of special-casing and ignore-errors for root-object-object.
;;
(root-object-object-vt
(when (and (ignore-errors (the root-object-object))
(not (eql (the root-object-object) self)))
(mapcar #'(lambda(path)
(when (consp (rest path))
(cons (append (first path) (list :root-object-object))
(rest path))))
(gdl-acc::%version-tree% (ignore-errors (the root-object-object)))))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ((root-path (remove :root-object-object (the root-path)))
;;(root-path (the root-path))
(root-path-length (length root-path))
(version-tree (if (and (the parent)
(ignore-errors (the parent root-object-object))
(eql (the parent root-object-object) self))
(remove-if-not #'(lambda(path)
(eql (lastcar (first path))
:root-object-object))
(gdl-acc::%version-tree% (the parent)))
(gdl-acc::%version-tree% (the root))))
(version-tree
(when replace-bashed-values?
(append
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
version-tree)
root-object-object-vt))))
(when *debug?* (print-variables version-tree))
(dolist (version-node version-tree (values))
(let ((root (the root))
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value)))))
(plist-keys value-plist) (plist-values value-plist)))))))))
(format t "~&~%Changes in 1588p002:~%~%~a~%~%" *1588p002-doc*)
(in-package :gdl)
(defparameter *1588p003-doc*
"Fix restore-slot-default to blank out version information at the true root
in the case that we are a root-object-object child of true parent.")
(define-object-amendment vanilla-mixin* ()
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
in the slot. Any dependent slots in the tree will respond accordingly when they are next demanded.
Note that the slot must be specified as a keyword symbol (i.e. prepended with a colon (``:'')),
otherwise it will be evaluated as a variable according to normal Lisp functional evaluation rules.
:arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))))
(format t "~&~%Changes in 1588p003:~%~%~a~%~%" *1588p003-doc*)
(in-package :gdl)
(defparameter *1588p004-doc*
"1. Fix restore-tree to restore to true root, and protect root-object-object
(the object of tasty or ta2) from being blown away and replaced with new object.
2. Make write-snapshot remove the root-object-object from root-paths if called on
root-object-object below toplevel parent.
3. Update the update! method to retrieve the version information from
the true root, in the case we are working on a root-object-object
below the toplevel parent.
")
(define-object-amendment vanilla-mixin* ()
:functions
(("Void. Restores all settable-slots in this instance, and
recursively in all descendant instances, to their default values."
restore-tree!
(&key (quick? t)
(keep-function #'always)
(prune-function #'never)
(child-function (lambda(node) (the-object node safe-children))))
(let ((node (if (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))
(the parent) self)))
(if quick?
(progn
(setf (gdl-acc::%version-tree% node) nil)
(the-object node (update! :immune-message-keys (list :root-object-object
:root-object-type)))
(unless (eql self node) (the-object node root-object-object update!)))
(maptree self
(lambda(node) (when (typep node 'gdl::gdl-basis) (the-object node restore-node!)))
keep-function
prune-function
child-function))))
("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the
current instance. Typically this file can be read back into the system using the <tt>read-snapshot</tt> function.
:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. The target file to be written.\"
(root-paths-to-ignore nil) \"List of root-paths or nil. Any objects with matching root-path will be ignored for the snapshot write.\"
)"
write-snapshot
(&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))
(let (*print-level*
(root-object-object? (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))))
(with-open-file (out filename :direction :output :if-exists :supersede :if-does-not-exist :create)
(print `(in-package ,(make-keyword (package-name *package*))) out)
(mapcar #'(lambda(node)
(let ((root-path (first node)) (value-plist (rest node)))
(unless (or (member root-path root-paths-to-ignore :test #'equalp)
(and root-object-object?
(not (eql (lastcar root-path) :root-object-object))))
(when root-object-object?
(setq root-path (if (consp (rest root-path))
(butlast root-path)
(the type))))
(let ((keys (plist-keys value-plist)) (values (plist-values value-plist)))
(let ((snap (cons root-path
(append (when (atom root-path)
(let (result)
(let* ((toplevel-inputs
(remove-plist-key (the root active-inputs)
:remote-id))
(toplevel-input-keys (plist-keys toplevel-inputs))
(toplevel-input-values (plist-values toplevel-inputs)))
(mapc #'(lambda(key value)
(when (not (member key keys))
(push key result) (push value result)))
toplevel-input-keys toplevel-input-values))
(nreverse result)))
(mapcan #'(lambda(key val)
(let ((expression (readable-expression val self)))
(unless (eql expression :%unreadable%)
(list key expression))))
keys values))))) (print snap out))))))
(or (gdl-acc::%version-tree% (if root-object-object? (the root parent) (the root)))
(list nil)))))
filename)
("Void. Uncaches all cached data in slots and objects throughout the instance
tree from this node, forcing all code to run again the next time values are
demanded. This is useful for updating an existing model or part of an existing
model after making changes and recompiling/reloading the code of the underlying
definitions. Any set (modified) slot values will, however, be preserved
by the update."
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(when *debug?* (print-variables version-tree))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value)))))
(plist-keys value-plist) (plist-values value-plist)))))))))
(format t "~&~%Changes in 1588p004:~%~%~a~%~%" *1588p004-doc*)
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