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)
(print
(page-walk (x "http://planet.lisp.org/2019/3.html" :recur recur)
(let prev "tr:first-child > td > a"
("href" x))
(page-walk-each
(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 @@
(type (eql :element)) (tag (eql :sub)) element)
(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
((protocol recurse-on-noscript-mixin)
((protocol recur-on-noscript-mixin)
(type (eql :element)) (tag (eql :noscript))
element)
(html-element-to-text
......@@ -249,6 +249,10 @@
element))))))
(defclass html-textifier-protocol-inspector
(recurse-on-noscript-mixin
(recur-on-noscript-mixin
show-formatting-mixin show-ui-texts-mixin show-urls-mixin
html-textifier-protocol) ())
(defun html-inner-text (element)
(html-element-to-text
element (make-instance 'html-textifier-protocol)))
......@@ -8,6 +8,7 @@
#:html-textifier-protocol
#:html-textifier-protocol-inspector
#:html-element-to-text
#:html-inner-text
#:save-web-page
#:save-web-form
#:parsed-content
......@@ -19,5 +20,9 @@
#:parse-obtained-content
#:*base-url*
#:real-url
#:page-walk
#:page-walk-each
#:page-walk-each-of
#:page-walk-maybe-each-of
))
......@@ -24,4 +24,5 @@
(:file "basic-retrieve" :depends-on ("package" "charsets" "urlencode"))
(:file "html-textify" :depends-on ("basic-retrieve"))
(: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 ()
((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 ()))
......@@ -8,12 +12,22 @@
(null (page-walker-branches x)))
(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)))
(if (null l) *page-walker-terminator*
(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)
(cond ((typep x 'page-walker-brancher)
(loop for y in (page-walker-branches x)
......@@ -22,23 +36,24 @@
(list y))))
(t x)))
(defmacro page-walker-brancher-progn (&rest forms)
(defmacro page-walk-each (&rest forms)
(let ((var (gensym)))
`(page-walker-brancher
`(page-walk-each-of
,(if (null forms) nil
`(let ((,var ,(first forms)))
(unless (page-walker-terminator-p ,var)
(list ,var
(page-walker-brancher-progn ,@(rest forms)))))))))
(page-walk-each ,@(rest forms)))))))))
(defun page-walker-clause-to-form (clause var env &key
(extra-functions nil)
(extra-macros nil)
(aggressive t)
(fetcher-var nil)
(body nil))
(cond ((and aggressive
(stringp clause))
`(page-walker-brancher (css-selectors:query ,clause ,var)))
`(page-walk-each-of (css-selectors:query ,clause ,var)))
((and (listp clause)
(stringp (first clause)))
`(html5-parser:element-attribute ,(second clause) ,(first clause)))
......@@ -47,19 +62,21 @@
(symbolp (second clause)))
(values
(let ((main-form
`(with-page (,var ,var :fetch nil
:keep-brancher t)
`(page-walk (,var ,var :fetch nil
:keep-brancher t
:fetcher-var fetcher-var)
,@body))
(result-var (second clause))
(rest-result-var (gensym))
(descend (gensym "let-clause-convertor")))
`(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)))))
(labels ((,descend (,result-var)
(if (typep ,result-var
'page-walker-brancher)
(page-walker-brancher
(page-walk-each-of
(loop for ,var in
(page-walker-branches
,result-var)
......@@ -77,9 +94,36 @@
((and (listp clause)
(eq (first clause) 'vector))
`(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))
'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
:body
`((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))
(multiple-value-bind
(subform full)
(page-walker-clause-to-form
(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)
(consp clause)
(symbolp (first clause))
......@@ -93,17 +137,15 @@
arg var env
:extra-functions extra-functions
:extra-macros extra-macros
:fetcher-var fetcher-var
:aggressive nil))))
(t clause)))
(defun html-to-text (element)
(html-element-to-text (make-instance 'html-textifier-protocol)
element))
(defmacro with-page ((var value &key
(defmacro page-walk ((var value &key
(recurse nil)
(recur nil)
(fetcher '(make-instance 'http-fetcher))
(fetcher-var (gensym))
(fetch t)
(use-fetcher nil)
(keep-brancher nil))
......@@ -111,7 +153,6 @@
&environment env)
(assert (not (and recur recurse)))
(let* ((recur (or recur recurse))
(fetcher-var (gensym))
(top-wrapper (if fetch
`(let* ((,fetcher-var ,fetcher)
(*base-url* ,var)
......@@ -130,20 +171,22 @@
first-clause var env
:extra-functions (list recur)
:extra-macros nil
:fetcher-var fetcher-var
:aggressive t
:body (rest body))
(if full form
(let ((result-var (gensym))
(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-result-var (gensym))
(descend (gensym "with-page")))
(descend (gensym "page-walk")))
`(let ((,result-var ,form))
(labels ((,descend (,result-var)
(if (typep ,result-var
'page-walker-brancher)
(page-walker-brancher
(page-walk-each-of
(loop for ,var in
(page-walker-branches
,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