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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

(define-module (render notice-markup)
  #:use-module (srfi srfi-1) ; list utils
  #:use-module (ice-9 regex)
  #:use-module (render profile)
  #:use-module (database-fetch)
  #:export (parse-notice-markup
            rendered-notice-sxml
            rendered-notice-side-products))

(define (make-render-result sxml side-products)
  `((sxml . ,sxml)
    (side-products . ,side-products)))

(define (input-sxml input)
  (assoc-ref input 'sxml))
(define (input-side-products input)
  (assoc-ref input 'side-products))
(define rendered-notice-sxml input-sxml)
(define rendered-notice-side-products input-side-products)

(define (map-texts proc sxml)
  (map (lambda (tag)
         (cond ((string? tag) (proc tag))
               ;; ignore attributes
               ((and (list? tag)
                     (not (null? tag))
                     (symbol? (car tag))
                     (eq? (car tag) '@))
                tag)
               ((list? tag) (map-texts proc tag))
               (else tag)))
       sxml))

(define (render-quotes db input)
  (make-render-result
   (map-texts (lambda (text)
                (define match (string-match "(.+)?(>[^\r\n]+)(\r?\n|$)(.*)" text))
                (define rest (and match (match:substring match 4)))
                (cond ((not match) text)
                      ((match:substring match 2)
                       `(,(or (match:substring match 1) "") ;prev
                         (span (@ (class "text-quote"))
                               ,(match:substring match 2))
                         (br)
                         ;; rest
                         ,(if rest
                              (car (input-sxml
                                    (render-quotes
                                     db
                                     (make-render-result
                                      (list rest)
                                      (input-side-products input)))))
                              "")))
                      (else text)))
              (input-sxml input))
   (input-side-products input)))

(define (render-newlines-to-br db input)
  (make-render-result
   (map-texts (lambda (text)
                (define match (string-match "([^\r\n]+)?\r?\n(.+)$" text))
                (cond ((not match) text)
                      (else
                       `(,(or (match:substring match 1) "") ;prev
                         '(br)
                         ;; rest
                         ,(car (input-sxml
                                (render-newlines-to-br
                                 db
                                 (make-render-result
                                  (list (match:substring match 2))
                                  (input-side-products input)))))))))
              (input-sxml input))
   (input-side-products input)))

(define (render-links db input)
  input)

(define (render-ats db input)
  (define side-products (input-side-products input))
  (define content
    (map-texts
     (lambda (text)
       (define match (string-match "([^@]+)?@([^ \r\n@]+)(@(\\S+))?@?(.*)$" text))
       (cond ((not match) text)
             ((match:substring match 2)
              (let* ((handle (if (match:substring match 3)
                                 (string-append (match:substring match 2)
                                                (match:substring match 3))
                                 (match:substring match 2)))
                     (profile (profile-for-handle db handle))
                     (new-side-products (cons `(mention . ,(or profile handle)) side-products))
                     (rest-result (render-ats db (make-render-result
                                                  (list (match:substring match 5))
                                                  new-side-products))))
                (set! side-products (input-side-products rest-result))
                `(,(or (match:substring match 1) "") ;prev
                  (a (@ (href ,(make-profile-url-local profile))
                        (class "mention"))
                     ,(string-append "@" (match:substring match 2)))
                  ;; host
                  ;; ,(match:substring match 4)
                  ;; rest
                  ,(car (input-sxml rest-result)))))
             (else text)))
     (input-sxml input)))
  (make-render-result content side-products))

(define (sanitize db input)
  input
  ;; (make-render-result
  ;;  (filter
  ;;   identity
  ;;   (map (lambda (item)
  ;;          (cond
  ;;           ;; remove empty strings
  ;;           ((and (string? item)
  ;;                 (string-null? item))
  ;;            item)
  ;;           ;; TODO join multi string lists
  ;;           ;; unwrap single string lists '("asdf") -> "asdf"
  ;;           ((and (list? item)
  ;;                 (= (length item) 1)
  ;;                 (string? (car item)))
  ;;            (car item))
  ;;           ;; remove empty lists '(() (asdf) (x)) -> ((asdf) (x))
  ;;           ((list? item)
  ;;            (filter (lambda (subitem)
  ;;                      (and (list? subitem)
  ;;                           (null? subitem)))
  ;;                    item))
  ;;           (else item)))
  ;;        (input-sxml input)))
  ;;  (input-side-products input))
  )

(define (parse-notice-markup db text)
  (fold (lambda (render-fn acc)
          (render-fn db acc))
        (make-render-result
         (list text)
         '())
        (list render-links
              render-quotes
              render-ats
              render-newlines-to-br
              sanitize)))