Commit b10bff32 authored by  's avatar  

Syncing from Monotone at 20190405-024726. Last commit message was Import...

Syncing from Monotone at 20190405-024726. Last commit message was Import Planet.Lisp.Org example, make it work with empty latest-month
parent f4d03155
(use-package :thoughtful-theridion)
(page-walk (x "" :recur recur)
(let prev "tr:first-child > td > a"
("href" x))
(page-walk (x x :fetch nil :keep-brancher t)
(page-walk-maybe-each-of "li > a")
("href" x)
(if (cl-ppcre:scan "/201[0-8]/" x)
(page-walk-each) x))
(recur prev))))
...@@ -234,10 +234,10 @@ ...@@ -234,10 +234,10 @@
(type (eql :element)) (tag (eql :sub)) element) (type (eql :element)) (tag (eql :sub)) element)
(format nil "{↓↓ ~a ↓↓}" (call-next-method))) (format nil "{↓↓ ~a ↓↓}" (call-next-method)))
(defclass recurse-on-noscript-mixin (html-textifier-protocol) ()) (defclass recur-on-noscript-mixin (html-textifier-protocol) ())
(defmethod html-element-to-text-dispatch (defmethod html-element-to-text-dispatch
((protocol recurse-on-noscript-mixin) ((protocol recur-on-noscript-mixin)
(type (eql :element)) (tag (eql :noscript)) (type (eql :element)) (tag (eql :noscript))
element) element)
(html-element-to-text (html-element-to-text
...@@ -249,6 +249,10 @@ ...@@ -249,6 +249,10 @@
element)))))) element))))))
(defclass html-textifier-protocol-inspector (defclass html-textifier-protocol-inspector
(recurse-on-noscript-mixin (recur-on-noscript-mixin
show-formatting-mixin show-ui-texts-mixin show-urls-mixin show-formatting-mixin show-ui-texts-mixin show-urls-mixin
html-textifier-protocol) ()) html-textifier-protocol) ())
(defun html-inner-text (element)
element (make-instance 'html-textifier-protocol)))
...@@ -8,6 +8,7 @@ ...@@ -8,6 +8,7 @@
#:html-textifier-protocol #:html-textifier-protocol
#:html-textifier-protocol-inspector #:html-textifier-protocol-inspector
#:html-element-to-text #:html-element-to-text
#:save-web-page #:save-web-page
#:save-web-form #:save-web-form
#:parsed-content #:parsed-content
...@@ -19,5 +20,9 @@ ...@@ -19,5 +20,9 @@
#:parse-obtained-content #:parse-obtained-content
#:*base-url* #:*base-url*
#:real-url #:real-url
)) ))
...@@ -24,4 +24,5 @@ ...@@ -24,4 +24,5 @@
(:file "basic-retrieve" :depends-on ("package" "charsets" "urlencode")) (:file "basic-retrieve" :depends-on ("package" "charsets" "urlencode"))
(:file "html-textify" :depends-on ("basic-retrieve")) (:file "html-textify" :depends-on ("basic-retrieve"))
(:file "html-forms" :depends-on ("package")) (:file "html-forms" :depends-on ("package"))
(:file "util" :depends-on ("basic-retrieve" "html-textify")))) (:file "util" :depends-on ("basic-retrieve" "html-textify"))
(:file "walker-dsl" :depends-on ("package" "basic-retrieve"))))
(in-package :thoughtful-theridion)
(defclass page-walker-brancher () (defclass page-walker-brancher ()
((branches :accessor page-walker-branches ((branches :accessor page-walker-branches
:initform nil :initarg :branches))) :initform nil :initarg :branches :type list)))
(defclass page-walker-brancher-skippable (page-walker-brancher) ())
(defvar *page-walker-terminator* (make-instance 'page-walker-brancher :branches ())) (defvar *page-walker-terminator* (make-instance 'page-walker-brancher :branches ()))
...@@ -8,12 +12,22 @@ ...@@ -8,12 +12,22 @@
(null (page-walker-branches x))) (null (page-walker-branches x)))
(defmethod page-walker-terminator-p ((x t)) nil) (defmethod page-walker-terminator-p ((x t)) nil)
(defmethod page-walker-terminator-p ((x page-walker-brancher-skippable)) nil)
(defun page-walker-brancher (l) (defmethod page-walk-each-of ((l list))
(let* ((l (remove-if 'page-walker-terminator-p l))) (let* ((l (remove-if 'page-walker-terminator-p l)))
(if (null l) *page-walker-terminator* (if (null l) *page-walker-terminator*
(make-instance 'page-walker-brancher :branches l)))) (make-instance 'page-walker-brancher :branches l))))
(defmethod page-walk-each-of ((l page-walker-brancher))
(page-walk-each-of (page-walker-branches l)))
(defmethod page-walk-maybe-each-of ((l list))
(make-instance 'page-walker-brancher-skippable :branches l))
(defmethod page-walk-maybe-each-of ((l page-walker-brancher))
(page-walk-maybe-each-of (page-walker-branches l)))
(defun page-walker-brancher-content (x) (defun page-walker-brancher-content (x)
(cond ((typep x 'page-walker-brancher) (cond ((typep x 'page-walker-brancher)
(loop for y in (page-walker-branches x) (loop for y in (page-walker-branches x)
...@@ -22,23 +36,24 @@ ...@@ -22,23 +36,24 @@
(list y)))) (list y))))
(t x))) (t x)))
(defmacro page-walker-brancher-progn (&rest forms) (defmacro page-walk-each (&rest forms)
(let ((var (gensym))) (let ((var (gensym)))
`(page-walker-brancher `(page-walk-each-of
,(if (null forms) nil ,(if (null forms) nil
`(let ((,var ,(first forms))) `(let ((,var ,(first forms)))
(unless (page-walker-terminator-p ,var) (unless (page-walker-terminator-p ,var)
(list ,var (list ,var
(page-walker-brancher-progn ,@(rest forms))))))))) (page-walk-each ,@(rest forms)))))))))
(defun page-walker-clause-to-form (clause var env &key (defun page-walker-clause-to-form (clause var env &key
(extra-functions nil) (extra-functions nil)
(extra-macros nil) (extra-macros nil)
(aggressive t) (aggressive t)
(fetcher-var nil)
(body nil)) (body nil))
(cond ((and aggressive (cond ((and aggressive
(stringp clause)) (stringp clause))
`(page-walker-brancher (css-selectors:query ,clause ,var))) `(page-walk-each-of (css-selectors:query ,clause ,var)))
((and (listp clause) ((and (listp clause)
(stringp (first clause))) (stringp (first clause)))
`(html5-parser:element-attribute ,(second clause) ,(first clause))) `(html5-parser:element-attribute ,(second clause) ,(first clause)))
...@@ -47,19 +62,21 @@ ...@@ -47,19 +62,21 @@
(symbolp (second clause))) (symbolp (second clause)))
(values (values
(let ((main-form (let ((main-form
`(with-page (,var ,var :fetch nil `(page-walk (,var ,var :fetch nil
:keep-brancher t) :keep-brancher t
:fetcher-var fetcher-var)
,@body)) ,@body))
(result-var (second clause)) (result-var (second clause))
(rest-result-var (gensym)) (rest-result-var (gensym))
(descend (gensym "let-clause-convertor"))) (descend (gensym "let-clause-convertor")))
`(let ((,result-var `(let ((,result-var
(with-page (,var ,var :fetch nil :keep-brancher t) (page-walk (,var ,var :fetch nil :keep-brancher t
:fetcher-var fetcher-var)
,@(rest (rest clause))))) ,@(rest (rest clause)))))
(labels ((,descend (,result-var) (labels ((,descend (,result-var)
(if (typep ,result-var (if (typep ,result-var
'page-walker-brancher) 'page-walker-brancher)
(page-walker-brancher (page-walk-each-of
(loop for ,var in (loop for ,var in
(page-walker-branches (page-walker-branches
,result-var) ,result-var)
...@@ -77,9 +94,36 @@ ...@@ -77,9 +94,36 @@
((and (listp clause) ((and (listp clause)
(eq (first clause) 'vector)) (eq (first clause) 'vector))
`(coerce `(coerce
(with-page (,var ,var :fetch nil :keep-brancher t) (page-walk (,var ,var :fetch nil :keep-brancher t
:fetcher-var fetcher-var)
,@(rest clause)) ,@(rest clause))
'vector)) 'vector))
((and (listp clause)
(eq (first clause) 'assert))
(let ((subform (page-walker-clause-to-form
(second clause) var env
:extra-functions extra-functions
:extra-macros extra-macros
:fetcher-var fetcher-var
:aggressive t
`((progn (error "unsupported kind of assertion")))))
(subvar (gensym)))
`(let ((,subvar ,subform))
(assert ,subvar nil ,@(cdddr clause))
,(or (third clause) subvar))))
((and (listp clause)
(eq (first clause) 'page-walk-maybe-each-of))
(subform full)
(second clause) var env
:extra-functions extra-functions
:extra-macros :extra-macros
:fetcher-var fetcher-var
:aggressive t
:body body)
(values `(page-walk-maybe-each-of ,subform) full)))
((and (listp clause) ((and (listp clause)
(consp clause) (consp clause)
(symbolp (first clause)) (symbolp (first clause))
...@@ -93,17 +137,15 @@ ...@@ -93,17 +137,15 @@
arg var env arg var env
:extra-functions extra-functions :extra-functions extra-functions
:extra-macros extra-macros :extra-macros extra-macros
:fetcher-var fetcher-var
:aggressive nil)))) :aggressive nil))))
(t clause))) (t clause)))
(defun html-to-text (element) (defmacro page-walk ((var value &key
(html-element-to-text (make-instance 'html-textifier-protocol)
(defmacro with-page ((var value &key
(recurse nil) (recurse nil)
(recur nil) (recur nil)
(fetcher '(make-instance 'http-fetcher)) (fetcher '(make-instance 'http-fetcher))
(fetcher-var (gensym))
(fetch t) (fetch t)
(use-fetcher nil) (use-fetcher nil)
(keep-brancher nil)) (keep-brancher nil))
...@@ -111,7 +153,6 @@ ...@@ -111,7 +153,6 @@
&environment env) &environment env)
(assert (not (and recur recurse))) (assert (not (and recur recurse)))
(let* ((recur (or recur recurse)) (let* ((recur (or recur recurse))
(fetcher-var (gensym))
(top-wrapper (if fetch (top-wrapper (if fetch
`(let* ((,fetcher-var ,fetcher) `(let* ((,fetcher-var ,fetcher)
(*base-url* ,var) (*base-url* ,var)
...@@ -130,20 +171,22 @@ ...@@ -130,20 +171,22 @@
first-clause var env first-clause var env
:extra-functions (list recur) :extra-functions (list recur)
:extra-macros nil :extra-macros nil
:fetcher-var fetcher-var
:aggressive t :aggressive t
:body (rest body)) :body (rest body))
(if full form (if full form
(let ((result-var (gensym)) (let ((result-var (gensym))
(rest-form (rest-form
`(with-page (,var ,var :fetch nil :keep-brancher t) `(page-walk (,var ,var :fetch nil :keep-brancher t
:fetcher-var fetcher-var)
,@(rest body))) ,@(rest body)))
(rest-result-var (gensym)) (rest-result-var (gensym))
(descend (gensym "with-page"))) (descend (gensym "page-walk")))
`(let ((,result-var ,form)) `(let ((,result-var ,form))
(labels ((,descend (,result-var) (labels ((,descend (,result-var)
(if (typep ,result-var (if (typep ,result-var
'page-walker-brancher) 'page-walker-brancher)
(page-walker-brancher (page-walk-each-of
(loop for ,var in (loop for ,var in
(page-walker-branches (page-walker-branches
,result-var) ,result-var)
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