1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
(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) ""))