Sat Nov 21 16:12:13 UTC 2009 pix@kepibu.org

* Status commit

--- old-Oh, Ducks!/chtml.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/chtml.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -7,22 +7,18 @@

(export 'pt)

(export 'lhtml))

-(defclass lhtml-template (html-template) ())

-(defclass pt-template (html-template) ())

+(defclass html-template (css-selector-template) ())

-(defmethod document-parser ((template lhtml-template))

- (lambda (document) (chtml:parse document (chtml:make-lhtml-builder))))

-(defmethod document-parser ((template pt-template))

- (lambda (document) (chtml:parse document (chtml:make-pt-builder))))

+(add-handler 'pt 'chtml:make-pt-builder)

+(add-handler 'lhtml 'chtml:make-lhtml-builder)

-(defmethod make-template-for-parser ((parser (eql 'lhtml)) spec)

- (make-instance 'lhtml-template :spec spec))

-(defmethod make-template-for-parser ((parser (eql :lhtml)) spec)

- (make-template-for-parser 'lhtml spec))

+(unless *default-parser*

+ (setf *default-parser* (rcurry #'chtml:parse (get-handler-for-model 'pt))))

-(defmethod make-template-for-parser ((parser (eql 'pt)) spec)

- (make-instance 'pt-template :spec spec))

-(defmethod make-template-for-parser ((parser (eql :pt)) spec)

- (make-template-for-parser 'pt spec))

-

-(unless *default-parser* (setf *default-parser* 'pt))

+(defmethod make-template ((kind (eql 'html)) (spec cons))

+ (destructuring-bind (&key parser model)

+ (append (when (%spec-includes-opts spec) (second spec))

+ (list :model 'pt))

+ (make-instance 'html-template

+ :parser (or parser (rcurry #'chtml:parse (get-handler-for-model model)))

+ :spec spec)))

--- old-Oh, Ducks!/cxml.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/cxml.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -3,14 +3,17 @@

(eval-when (:compile-toplevel :load-toplevel :execute)

(export 'dom))

-(defclass dom-template (xml-template) ())

+(defclass xml-template (css-selector-template) ())

-(defmethod document-parser ((template dom-template))

- (lambda (document) (cxml:parse document (cxml-dom:make-dom-builder))))

+(add-handler 'dom 'cxml-dom:make-dom-builder)

-(defmethod make-template-for-parser ((parser (eql 'dom)) spec)

- (make-instance 'dom-template :spec spec))

-(defmethod make-template-for-parser ((parser (eql :dom)) spec)

- (make-template-for-parser 'dom spec))

+(unless *default-parser*

+ (setf *default-parser* (rcurry #'cxml:parse (get-handler-for-model 'dom))))

-(unless *default-parser* (setf *default-parser* 'dom))

+(defmethod make-template ((kind (eql 'xml)) (spec cons))

+ (destructuring-bind (&key parser model)

+ (append (when (%spec-includes-opts spec) (second spec))

+ (list :model 'pt))

+ (make-instance 'xml-template

+ :parser (or parser (rcurry #'cxml:parse (get-handler-for-model model)))

+ :spec spec)))

--- old-Oh, Ducks!/notes 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/notes 2013-06-22 21:30:25.000000000 +0000

@@ -1,6 +1,8 @@

#-*-mode: org;-*-

* To Do

-** working lhtml/xmls support

+** working lhtml/xmls support [1/2]

+ * [X] non-descendant cases (class, id, etc.)

+ * [ ] selectors involving descendants

** write documentation

** improve selector support

*** positional selectors

--- old-Oh, Ducks!/oh-ducks.asd 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/oh-ducks.asd 2013-06-22 21:30:25.000000000 +0000

@@ -17,16 +17,12 @@

:maintainer "pinterface <pix@kepibu.org>"

:author "pinterface <pix@kepibu.org>"

:licence "BSD-style"

- ;; TODO: submit a patch for cl-unification to use

- ;; asdf-system-connections. Getting an unmodified version of

- ;; cl-unification to load the cl-ppcre stuff is a PITA.

:depends-on (:cl-unification :cl-ppcre :split-sequence :alexandria)

:serial t

:components ((:file "package")

(:file "regexp-template")

(:module "traversal"

- :components

- ((:file "interface")))

+ :components ((:file "interface")))

(:file "selectors")

(:file "templates")

(:file "unify")

@@ -36,7 +32,7 @@

:requires (:oh-ducks :closure-html)

:components ((:file "chtml")

(:module "traversal"

- :components (#+FIXME (:file "lhtml")

+ :components ((:file "lhtml")

(:file "pt")))))

(defsystem-connection ducks+cxml

--- old-Oh, Ducks!/package.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/package.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -1,5 +1,12 @@

+(defpackage #:oh-ducks.functional

+ (:import-from #:alexandria . #1=(

+ #:compose

+ #:curry

+ #:rcurry))

+ (:export . #1#))

+

(defpackage #:oh-ducks.traversal

- (:use #:cl)

+ (:use #:cl #:oh-ducks.functional)

(:export #:element-children

#:element-parent

#:element-attribute

@@ -11,11 +18,7 @@

#:element-ancestors))

(defpackage #:oh-ducks

- (:use #:cl #:unify #:oh-ducks.traversal)

- (:import-from #:alexandria

- #:compose

- #:curry

- #:rcurry)

+ (:use #:cl #:unify #:oh-ducks.functional #:oh-ducks.traversal)

(:export ;; template machinery

#:*default-parser*

#:html

--- old-Oh, Ducks!/selectors.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/selectors.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -22,7 +22,7 @@

(:method ((ob t)) nil))

(defmethod print-object ((selector combinator) stream)

- (format stream "#<combinator>"))

+ (format stream "#<~s ~s>" (class-name (class-of selector)) (matcher selector)))

(defclass child-combinator (combinator) ())

(defclass descendant-combinator (combinator) ())

@@ -52,17 +52,15 @@

(#T(regexp$ "(\\w+)" (?type)) (cons (make-instance 'type-selector :arg type) (parse-selector &rest)))

(#T(regexp$ "\\*" ()) (cons (make-instance 'universal-selector) (parse-selector &rest)))))

-(defgeneric find-matching-elements (selector elements))

-

-(defmethod find-matching-elements (selector (elements list))

- (nconc

- (remove-if-not (rcurry #'element-matches-p selector) elements)

- (reduce #'nconc

- (mapcar (compose (curry #'find-matching-elements selector) #'element-children)

- elements))))

-

-(defmethod find-matching-elements (selector (elements t))

- (find-matching-elements selector (list elements)))

+(defgeneric find-matching-elements (selector element)

+ (:method (selector (element t))

+ (flet ((find-in-list (elements)

+ (mapcar (curry #'find-matching-elements selector)

+ elements)))

+ (nconc

+ (when (element-matches-p element selector) (list element))

+ (reduce #'nconc

+ (find-in-list (element-children element)))))))

(defgeneric element-matches-p (element selector))

@@ -84,6 +82,7 @@

(every (curry #'element-matches-p element) selector))

(defmethod element-matches-p (element (selector child-combinator))

+ (format t "cc:: el: ~s, s: ~s~%" (element-parent element) selector)

(element-matches-p (element-parent element) (matcher selector)))

(defmethod element-matches-p (element (selector descendant-combinator))

--- old-Oh, Ducks!/templates.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/templates.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -1,45 +1,26 @@

(in-package #:oh-ducks)

(defclass css-selector-template (unify::expression-template)

- ((parser :initarg :parser :initform nil) ;; subtype generally determines parser

+ ((parser :initarg :parser :initform nil) ;; subtype generally determines parser

(specifiers :reader specifiers) ;; list of (specifier . variable) and (specifier . template)

))

-;; FIXME: split html-template and xml-template into the cxml/chtml stuff; then,

-;; split dom-template into dom-html-template and dom-xml-template.

-;; Actually, just ditch the subtypes entirely, and build new objects with

-;; a specified handler type.

-(defclass xml-template (css-selector-template) ()) ;; parses xml

-

-(defclass html-template (css-selector-template) ()) ;; parses html

-

+(defvar *model-handler-map* nil "A mapping between model types and handler functions.")

+(defun add-handler (model handler)

+ (push (cons model handler) *model-handler-map*))

+(defun get-handler-for-model (model)

+ (let ((handler (cdr (assoc model *model-handler-map*))))

+ (typecase handler

+ (null nil)

+ (function (funcall handler))

+ (symbol (funcall (symbol-function handler)))

+ (t handler))))

(defvar *default-parser* nil "Determines the default parser when none is specified.")

-(defgeneric document-parser (template)

- (:documentation "Returns a function which, given an unparsed document, parses that document into some sort of structure."))

-

-(defmethod document-parser ((template css-selector-template))

- (slot-value template 'parser))

-

-(defgeneric make-template-for-parser (parser spec)

- (:documentation "Returns a template of the appropriate type for a given parser.")

- (:method ((parser t) spec)

- (make-instance 'css-selector-template :parser parser :spec spec))

- (:method ((parser null) spec)

- (declare (ignore parser spec))

- (error "No parser specified.")))

-

(defun %spec-includes-opts (spec)

(keywordp (first (second spec))))

-(defmethod make-template ((kind (eql 'html)) (spec cons))

- (destructuring-bind (&key parser)

- (if (%spec-includes-opts spec)

- (second spec)

- (list :parser *default-parser*))

- (make-template-for-parser parser spec)))

-

(defun combine-selectors (selector parent)

(let ((combinator (car (last selector))))

(cond

--- old-Oh, Ducks!/tests.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/tests.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -7,7 +7,7 @@

#+(or) (setq *default-parser* 'pt)

(equalp '(:div ((:id "id")) "I " (:i () "like") " cheese.")

- (match (#T(html ("#id" . ?div))

+ (match (#T(html (:model lhtml) ("#id" . ?div))

"<div id=\"id\">I <i>like</i> cheese.</div>")

;; FIXME: learn to distinguish between when there should only be one

;; result and when there should be many?

@@ -15,7 +15,8 @@

(equalp '((:div ((:class "red fish")) "one fish")

(:div ((:class "blue fish")) "two fish"))

- (match (#T(html (".fish" . ?divs)

+ (match (#T(html (:model lhtml)

+ (".fish" . ?divs)

(".pig" . ?pig))

"<div class='pig'>bricklayer</div><div class='red fish'>one fish</div><div class='blue fish'>two fish</div>")

;; pig doesn't affect the equalp...but does show separate things are separate

@@ -27,13 +28,15 @@

i))

(equalp '((:i () "not"))

- (match (#T(html ("div>i" . ?i))

+ (match (#T(html (:model dom)

+ ("div>i" . ?i))

"<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

i))

(equalp '((:i () "not"))

- (match (#T(html ("div" ("> i" . ?i)

- ("span>i" . ?span)))

+ (match (#T(html (:model dom)

+ ("div" ("i" . ?i)

+ ("span" . ?span)))

"<div>I do <i>not</i> like cheese.</div><div><span>I like <i>cheese</i>.</span></div>")

(values i span)))

--- old-Oh, Ducks!/traversal/dom.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/traversal/dom.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -1,11 +1,17 @@

(in-package #:oh-ducks.traversal)

+(defmethod oh-ducks::find-matching-elements (selector (element dom:document))

+ (oh-ducks::find-matching-elements selector (dom:document-element element)))

+

;;; general accessors

-(defmethod element-children ((element dom:node))

- (coerce (dom:child-nodes element) 'list))

-(defmethod element-parent ((element dom:node))

+(defmethod element-children ((element dom:element))

+ (remove-if-not #'dom:element-p (coerce (dom:child-nodes element) 'list)))

+(defmethod element-parent ((element dom:document))

+ nil)

+(defmethod element-parent ((element dom:element))

(dom:parent-node element))

+#+(or)

(defmethod element-attribute (attribute (element dom:node))

(declare (ignore attribute element))

nil)

@@ -13,6 +19,7 @@

(element-attribute (string-downcase (symbol-name attribute)) element))

(defmethod element-attribute ((attribute string) (element dom:element))

(dom:get-attribute element attribute))

+#+(or)

(defmethod element-type ((element dom:node))

(declare (ignore element))

nil)

@@ -20,6 +27,7 @@

(dom:tag-name element))

;;; special accessors in case something special needs to happen

+#+(or)

(defmethod element-id ((element dom:node))

(declare (ignore element))

nil)

--- old-Oh, Ducks!/traversal/interface.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/traversal/interface.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -6,13 +6,13 @@

;;; general accessors

(defgeneric element-children (element)

- (:documentation "Returns a sequence of element's element-children."))

+ (:documentation "Returns a sequence of element's child tags."))

(defgeneric element-parent (element)

- (:documentation "Returns element's element-parent element."))

+ (:documentation "Returns element's parent element."))

(defgeneric element-attribute (attribute element)

(:documentation "Returns the value of the attribute of element, or nil if no such attribute exists."))

(defgeneric element-type (element)

- (:documentation "Returns the tag name (element-type) of element."))

+ (:documentation "Returns the tag name (type) of element."))

;;; special accessors in case something special needs to happen

--- old-Oh, Ducks!/traversal/lhtml.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/traversal/lhtml.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -6,7 +6,8 @@

;;; general accessors

(defmethod element-children ((element list))

- (cddr element))

+ (remove-if-not (lambda (x) (and (listp x) (keywordp (car x))))

+ (cddr element)))

;; FIXME: bleh... may not even be worth trying to support this

#+FIXME

@@ -23,10 +24,10 @@

(defmethod element-ancestors ((element list))

(error "cannot get ancestors"))

-(defmethod element-attribute ((element-attribute symbol) (element list))

- (cadr (assoc element-attribute (cadr element))))

-(defmethod element-attribute ((element-attribute string) (element list))

- (element-attribute (intern (string-upcase element-attribute) :keyword) element))

+(defmethod element-attribute ((attribute symbol) (element list))

+ (cadr (assoc attribute (cadr element))))

+(defmethod element-attribute ((attribute string) (element list))

+ (element-attribute (intern (string-upcase attribute) :keyword) element))

(defmethod element-type ((element list))

(car element))

--- old-Oh, Ducks!/traversal/pt.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/traversal/pt.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -3,7 +3,8 @@

;;; general accessors

(defmethod element-children ((element chtml:pt))

- (chtml:pt-children element))

+ (remove-if (rcurry #'member '(:pcdata :comment) :test #'eq)

+ (chtml:pt-children element)))

(defmethod element-parent ((element chtml:pt))

(chtml:pt-parent element))

--- old-Oh, Ducks!/unify.lisp 2013-06-22 21:30:25.000000000 +0000

+++ new-Oh, Ducks!/unify.lisp 2013-06-22 21:30:25.000000000 +0000

@@ -13,11 +13,23 @@

&key &allow-other-keys)

(loop :for (css-specifier . template) :in (specifiers template)

:do

- (let ((val (find-matching-elements css-specifier document)))

+ (setf

+ env

+ (let ((val (find-matching-elements css-specifier document)))

+ #+(or) (if (null val) (cerror "continue" "null!"))

+ (format t "mel: ~s, css: ~s, tpl: ~s~%" val css-specifier template)

(cond

- ((unify::template-p template) (unify template val env))

- ((unify::variablep template) (unify::extend-environment template val env))

- (t (error "whoops: ~s, ~s" css-specifier template)))))

+ ((unify::template-p template)

+ #+(or) (format t "template-p~%")

+ (unify template val env)

+ #+(or) ;; FIXME: in the case of multiple items in val, this will only return one.

+ (loop :for element :in val

+ :do (setf env (unify template element env))

+ :finally (return env)))

+ ((unify::variablep template)

+ #+(or) (format t "variable-p~%")

+ (unify::extend-environment template val env))

+ (t (error "whoops: ~s, ~s" css-specifier template))))))

env)

(defmethod unify (document (template css-selector-template)

@@ -28,10 +40,9 @@

(defmethod unify ((template css-selector-template) (document string)

&optional (env (make-empty-environment))

&key &allow-other-keys)

- (unify template (funcall (document-parser template) document) env))

+ (unify template (funcall (slot-value template 'parser) document) env))

(defmethod unify ((template css-selector-template) (document pathname)

&optional (env (make-empty-environment))

&key &allow-other-keys)

- (unify template (funcall (document-parser template) document) env))

-

+ (unify template (funcall (slot-value template 'parser) document) env))