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