root/html.scm

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)
      ""))