(define-module (html)
#:use-module (srfi srfi-1)
#:export (html-match
html-text
html-match1
html-match-attr1))
(define (sxml-contains a b)
(define current (if (pair? a) (car a) a))
(define check (if (pair? b) (car b) b))
(define rest (if (pair? a) (cdr a) '()))
(define next-check (if (and (pair? b) (not (null? b)))
(cdr b)
#f))
(and (eqv? current check)
(if (and next-check (list? next-check) (not (null? next-check)))
(fold (lambda (value acc)
(define next-match (if (pair? next-check)
(car next-check)
next-check))
(if (pair? value)
(or acc (sxml-contains value next-match))
(or acc (equal? value next-match))))
#f
rest)
#t)))
(define* (html-match page tag #:optional (acc '()))
(define current (if (pair? page) (car page) page))
(define contains (sxml-contains page tag))
(define rest (if (and (list? current) (not (null? current)))
(cons current (cdr page) ;; (if (null? page) '() (cdr page))
)
(if (pair? page) (cdr page) '())))
(define next (if (null? rest) #f (car rest)))
(if (null? rest)
(if contains
(cons current acc)
acc)
(let ((tmp-result (fold (lambda (item acc2)
(if contains
(html-match item tag (cons page acc2))
(html-match item tag acc2)))
'()
rest)))
(if (null? tmp-result)
acc
(append tmp-result acc)))))
(define (html-match1 page tag)
;; TODO wasted computing time, because we could stop after the first result instead of reversing
(define result (reverse (html-match page tag)))
(if (pair? result)
(car result)
#f))
(define (html-match-attr1 page base-tag attr)
;; TODO FIXME this is pure shit, but it werks
;; completly wasted cycles due to stupidity
(define attr-container (html-match1 page (append base-tag `((@ (,attr))))))
(define attr-value (if attr-container
(cadr (html-match1 attr-container attr))
#f))
attr-value)
(define (html-fold-content tag init proc)
(fold (lambda (value acc)
(if (eq? '@ value)
acc
(proc value)))
init
tag))
(define (html-fold-content-recursive tag init proc)
(fold (lambda (value acc)
(if (eq? '@ value)
acc
(if (pair? value)
(html-fold-content-recursive value (proc value acc) proc)
(proc value acc))))
init
tag))
(define (html-text-recursive tag)
(html-fold-content-recursive tag "" (lambda (value acc)
(if (string? value)
(string-append acc value)
acc))))
(define (html-text tag)
(if tag
(fold (lambda (value acc)
(if (string? value)
(string-append acc value)
acc)) "" tag)
""))