Mon Nov 16 08:14:42 UTC 2009 pix@kepibu.org * Status commit diff -rN -u old-Oh, Ducks!/regexp-template.lisp new-Oh, Ducks!/regexp-template.lisp --- old-Oh, Ducks!/regexp-template.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/regexp-template.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -29,9 +29,12 @@ (destructuring-bind (re-kwd regexp &optional vars &rest keys) spec (declare (ignore re-kwd)) + (format t "rex: ~s, ~s~%" + (concatenate 'string "^(.*?)" regexp "$") + (append '(?&rest) vars)) (make-instance 'unify::regular-expression-template :spec (list* 'unify::regexp - (concatenate 'string "^(.*)" regexp "$") + (concatenate 'string "^(.*?)" regexp "$") (append '(?&rest) vars) keys)))) diff -rN -u old-Oh, Ducks!/selectors.lisp new-Oh, Ducks!/selectors.lisp --- old-Oh, Ducks!/selectors.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/selectors.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -53,13 +53,21 @@ (:method ((ob selector)) t) (:method ((ob t)) nil)) -(defclass simple-selector (simple-selector) +(defclass simple-selector (selector) ((arg :reader selector-arg :initarg :arg))) (defmethod print-object ((selector simple-selector) stream) (format stream "#" (selector-arg selector))) (defclass combinator (selector) ()) + +(defgeneric combinator-p (object) + (:method ((ob combinator)) t) + (:method ((ob t)) nil)) + +(defmethod print-object ((selector combinator) stream) + (format stream "#")) + (defclass child-combinator (combinator) ()) (defclass descendant-combinator (combinator) ()) (defclass adjacent-combinator (combinator) ()) @@ -69,12 +77,13 @@ (defclass id-selector (simple-selector) ()) (defclass class-selector (simple-selector) ()) -(defmethod initialize-instance :after ((template selector) &key) +(defmethod initialize-instance :after ((template combinator) &key) (unless (slot-boundp template 'matcher) (let ((selector (template-spec template))) (setf (slot-value template 'matcher) (parse-selector (string-trim " " selector)))))) ;; forwards +#+(or) (defun parse-selector (selector) (match-case (selector) ;; combinators @@ -86,16 +95,19 @@ (#T(regexp+ "^[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest))))) ;; backwards -#+(or) +;; FIXME: somehow, selector is ending up as "NIL" (defun parse-selector (selector) + (when (string= "NIL" selector) (error "selector is nil")) + (format t "selector: ~s~%" selector) + (macrolet ((prest (x) `(format t "rest~s: ~S~%" ,x &rest))) (match-case (selector) ;; combinators - (#T(regexp$ "[ ]*[>][ ]*" ()) (list (make-instance 'child-combinator :matcher (parse-selector &rest)))) - (#T(regexp$ "[ ]+" ()) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest)))) + (#T(regexp$ "[ ]*[>][ ]*" ()) (prest 'a) (list (make-instance 'child-combinator :matcher (parse-selector &rest)))) + (#T(regexp$ "[ ]+" ()) (prest 'b) (list (make-instance 'descendant-combinator :matcher (parse-selector &rest)))) ;; simple selector - (#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest))) - (#T(regexp$ "[#](\\w+)" (?id)) (cons (make-instance 'id-selector :arg id) (parse-selector &rest))) - (#T(regexp$ "[\\.](\\w+)" (?class)) (cons (make-instance 'class-selector :arg class) (parse-selector &rest))))) + (#T(regexp$ "[#](\\w+)" (?id)) (prest 'c) (cons (make-instance 'id-selector :arg id) (parse-selector &rest))) + (#T(regexp$ "[\\.](\\w+)" (?class)) (prest 'd) (cons (make-instance 'class-selector :arg class) (parse-selector &rest))) + (#T(regexp$ "(\\w+)" (?type)) (prest 'e) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))))) ;; FIXME: the find/matches split seems to be causing me some mental @@ -107,58 +119,85 @@ (defgeneric find-matching-elements (selector elements)) -(defmethod find-matching-elements ((selector simple-selector) (elements list)) - (nconc - (remove-if-not (lambda (el) (element-matches-p selector el)) elements) - (remove-if #'null - (mapcar (lambda (element) (find-matching-elements selector (element-children element))) - elements))) - #+(or) - (loop :for element :in elements - :when (element-matches-p selector element) - :collect element)) - -#+(or) ;; hrm...this doesn't seem right... doesn't handle combinators! -(defmethod find-matching-elements ((selector list) (elements list)) - (flet ((all-selectors-match (element) - (every (lambda (s) (element-matches-p s element)) selector))) - (remove-if-not #'all-selectors-match elements)) +(defmethod find-matching-elements ((selectors list) element) + (call-next-method) #+(or) - (loop :for element :in elements - :when (every (lambda (s) (element-matches-p m element)) selector) - :collect element)) - -(defvar *parent*) -;; if *parent* is equal to element-parent, we've found a child element. -;; But, uh, who sets *parent*? -(defmethod find-matching-elements ((selector child-combinator) (elements list)) - ) - -(defvar *ancestor*) - + (prog1 + (when (element-matches-p selectors element) + (when (every (alexandria:rcurry #'find-matching-elements element) selectors) + element) + (format t "lv fme~%")))) + +(defmethod find-matching-elements ((selector selector) (elements list)) + (call-next-method)) + +(defmethod find-matching-elements (selector (elements list)) + (format t "in fme: ~s~%" elements) + (prog1 + (nconc + (remove-if-not (lambda (el) (element-matches-p el selector)) elements) + (reduce #'nconc + (remove-if #'null + (mapcar (lambda (element) (find-matching-elements selector (element-children element))) + elements)))) + (format t "lv fme~%"))) + +(defmethod find-matching-elements (selector (elements t)) + (find-matching-elements selector (list elements))) + +;; for lhtml compatibility +#|| +(defvar *ancestors* nil) +(defmethod find-matching-elements ((selector selector) (elements cons)) + (if (keywordp (car elements)) + (remove-if #'null + (nconc + (when (element-matches-p elements selector) (list elements)) + (let ((*ancestors* (cons elements nil))) + (mapcar (lambda (el) (find-matching-elements selector el)) + (element-children elements))))) + (call-next-method))) +||# -(defgeneric element-matches-p (selector element)) +(defgeneric element-matches-p (element selector)) -(defmethod element-matches-p ((selector selector) (element t)) +(defmethod element-matches-p ((element t) (selector selector)) + (error "ar?") nil) +(defmethod element-matches-p :around ((element string) (selector selector)) + (call-next-method)) + +(defmethod element-matches-p :around ((element t) (selector selector)) + (call-next-method) + #+(or) + (format t "c: ~s, ~s, ~s~%" + (class-of element) + (class-of selector) + (find-method #'element-matches-p '() (list (find-class t) (class-of selector)) nil)) + #+(or) + (when (find-method #'element-matches-p '() (mapcar #'class-of (list element selector)) nil) + (call-next-method))) -(defmethod element-matches-p ((selector type-selector) element) +(defmethod element-matches-p (element (selector type-selector)) (element-type-equal element (selector-arg selector))) -(defmethod element-matches-p ((selector id-selector) element) +(defmethod element-matches-p (element (selector id-selector)) + ;(cerror "hrm" element) + (format t "id: ~s~%" (element-id element)) (string= (element-id element) (selector-arg selector))) -(defmethod element-matches-p ((selector class-selector) element) +(defmethod element-matches-p (element (selector class-selector)) (member (selector-arg selector) (element-classes element) :test #'string=)) -(defmethod element-matches-p ((selector child-combinator) element) +#+(or) +(defmethod element-matches-p (element (selector child-combinator)) (plusp (length (find-matching-elements selector (element-children element))))) #+TODO -(defmethod element-matches-p ((selector descendant-combinator) element) - (flet ((all-match (element) (every (lambda (m) (element-matches-p m element)) (matcher selector)))) +(defmethod element-matches-p (element (selector descendant-combinator)) + (flet ((all-match (element) (every (lambda (m) (element-matches-p element m)) (matcher selector)))) #+nil (when (all-match element) element) (let ((elements (cddr element))) @@ -168,3 +207,12 @@ :when (all-match element) :collect element)) (t (css-collect-elements selector elements)))))) + +(defmethod element-matches-p (element (selector list)) + (every (lambda (s) (element-matches-p element s)) selector)) + +(defmethod element-matches-p (element (selector child-combinator)) + (element-matches-p (element-parent element) (matcher selector))) + +(defmethod element-matches-p (element (selector descendant-combinator)) + (some (lambda (a) (element-matches-p a (matcher selector))) (element-ancestors element))) diff -rN -u old-Oh, Ducks!/tests.lisp new-Oh, Ducks!/tests.lisp --- old-Oh, Ducks!/tests.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/tests.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -1,7 +1,9 @@ (in-package #:css-selector-unifier) +;; FIXME: the switch to chtml:pt nodes means our #'equalp no longer +;; works. (equalp '(:div ((:id "id")) "I " (:i () "like") " cheese.") - (match (#T(lhtml ("#id" . ?div)) + (match (#T(html ("#id" . ?div)) "
I like cheese.
") ;; FIXME: learn to distinguish between when there should only be one ;; result and when there should be many? @@ -9,28 +11,24 @@ (equalp '((:div ((:class "red fish")) "one fish") (:div ((:class "blue fish")) "two fish")) - (match (#T(lhtml (".fish" . ?divs) - (".pig" . ?pig)) + (match (#T(html (".fish" . ?divs) + (".pig" . ?pig)) "
bricklayer
one fish
two fish
") ;; pig doesn't affect the equalp...but does show separate things are separate (values divs pig))) (equalp '((:i () "not") (:i () "cheese")) - (match (#T(lhtml ("div" ("i" . ?i))) + (match (#T(html ("div" ("i" . ?i))) "
I do not like cheese.
I like cheese.
") i)) (equalp '((:i () "not")) - (match (#T(lhtml ("div>i" . ?i)) + (match (#T(html ("div>i" . ?i)) "
I do not like cheese.
I like cheese.
") i)) -;; FIXME: it seems our options for this are either to return incorrect results -;; ((:i not) (:i cheese)) or make ?i fail to acknowledge all available -;; items under div>i. This probably means my strategy of implementation -;; is faulty. (equalp '((:i () "not")) - (match (#T(lhtml ("div" ("> i" . ?i))) + (match (#T(html ("div" ("> i" . ?i))) "
I do not like cheese.
I like cheese.
") i)) diff -rN -u old-Oh, Ducks!/traversal/interface.lisp new-Oh, Ducks!/traversal/interface.lisp --- old-Oh, Ducks!/traversal/interface.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/traversal/interface.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -18,7 +18,7 @@ (defgeneric element-id (element) (:documentation "Equivalent in spirit to (element-attribute :element-id element).") - (:method (element) (element-attribute :element-id element))) + (:method (element) (element-attribute :id element))) (defgeneric element-classes (element) (:documentation "Equivalent in spirit to (element-attribute :class element), except it returns a sequence of individual element-classes.") @@ -28,3 +28,10 @@ (defgeneric element-type-equal (element type) (:documentation "Equivalent in spirit to (string-equal (element-type element) element-type), but not obligated to work under the assumption of string-designators.") (:method (element type) (string-equal type (element-type element)))) + +(defgeneric element-ancestors (element) + (:documentation "The result of calling element-parent repeatedly up the document tree.") + (:method (element) + (let ((parent (element-parent element))) + (when parent + (cons parent (element-ancestors parent)))))) diff -rN -u old-Oh, Ducks!/traversal/lhtml.lisp new-Oh, Ducks!/traversal/lhtml.lisp --- old-Oh, Ducks!/traversal/lhtml.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/traversal/lhtml.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -8,11 +8,14 @@ (defmethod element-children ((element list)) (cddr element)) +;; FIXME: bleh... may not even be worth trying to support this (defmethod element-parent ((element list)) - ;; FIXME: figure out how to do this. Maybe we can do something involving - ;; signals and restart-cases. Ask "are you my mother?" up the stack, and - ;; only error if everybody says no. - (error "Unable to locate element-parent or suitable guardian.")) + (let ((parent (car *ancestors*))) + (if (some (alexandria:curry #'eq element) (element-children parent)) + parent + (error "unable to determine parent")))) +(defmethod element-ancestors ((element list)) + *ancestors*) (defmethod element-attribute ((element-attribute symbol) (element list)) (cadr (assoc element-attribute (cadr element)))) diff -rN -u old-Oh, Ducks!/traversal/pt.lisp new-Oh, Ducks!/traversal/pt.lisp --- old-Oh, Ducks!/traversal/pt.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/traversal/pt.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -9,7 +9,8 @@ (chtml:pt-parent element)) (defmethod element-attribute ((element-attribute symbol) (element chtml:pt)) - (getf (chtml:pt-attrs element) element-attribute)) + (unless (eq :pcdata (chtml:pt-name element)) + (getf (chtml:pt-attrs element) element-attribute))) (defmethod element-attribute ((element-attribute string) (element chtml:pt)) (element-attribute (intern (string-upcase element-attribute) :keyword) element)) diff -rN -u old-Oh, Ducks!/unification-templates.lisp new-Oh, Ducks!/unification-templates.lisp --- old-Oh, Ducks!/unification-templates.lisp 2015-09-30 10:05:16.000000000 +0000 +++ new-Oh, Ducks!/unification-templates.lisp 2015-09-30 10:05:16.000000000 +0000 @@ -5,8 +5,12 @@ (parser :reader parser) ;; subtype determines parser (handler :reader handler) ;; cxml/closure-html handler (specifiers :reader specifiers) ;; list of (specifier . variable) and (specifier . template) + #+(or) + (parent :reader parent-template :initarg :parent :initform nil) )) +(defmethod parent-template ((template t)) nil) + (defclass xml-template (css-selector-template) ()) ;; parses using closure-xml (defclass html-template (css-selector-template) ()) ;; parses using closure-html @@ -25,13 +29,32 @@ (setf (slot-value template 'specifiers) (parse-specifiers specifiers-and-vars 'lhtml-template)))) -(defun parse-specifiers (specs template-kind) +(defmethod initialize-instance :after ((template pt-template) &key css-specifiers parent &allow-other-keys) + (let ((specifiers-and-vars (or css-specifiers (rest (template-spec template))))) + (setf (slot-value template 'specifiers) + (parse-specifiers specifiers-and-vars template parent)))) + +(defun combine-selectors (selector parent) + (format t "sss: ~s~%" selector) + (let ((combinator (car (last selector)))) + (cond + ((null parent) + selector) + ((combinator-p combinator) + (format t "ok!~%") + (setf (slot-value combinator 'matcher) parent) + selector) + (t + (nconc selector (list (make-instance 'descendant-combinator :matcher parent))))))) + +(defun parse-specifiers (specs template parent) (loop :for (css-specifier . rest) :in specs - :collect (cons (make-instance 'css-specifier :spec css-specifier) + :for selector = (combine-selectors (parse-selector css-specifier) parent) + :collect (cons selector (cond ((unify::template-p rest) rest) ((unify::variablep rest) rest) - ((consp rest) (make-instance template-kind :css-specifiers rest)))))) + ((consp rest) (make-instance (class-of template) :css-specifiers rest :parent selector)))))) (defmethod unify ((a css-selector-template) (b css-selector-template) &optional (env (make-empty-environment)) @@ -47,7 +70,7 @@ (loop :for (css-specifier . template) :in (specifiers template) :do (format t "spec: ~s, tpl: ~s~%" css-specifier template) - (let ((val (css-select css-specifier document))) + (let ((val (find-matching-elements css-specifier document))) (format t "val: ~s~%" val) (cond ((unify::template-p template) (unify template val env)) @@ -59,3 +82,8 @@ &optional (env (make-empty-environment)) &key &allow-other-keys) (unify template (chtml:parse document (chtml:make-lhtml-builder)) env)) + +(defmethod unify ((template pt-template) (document string) + &optional (env (make-empty-environment)) + &key &allow-other-keys) + (unify template (chtml:parse document (chtml:make-pt-builder)) env))