You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
95 lines
4.1 KiB
Racket
95 lines
4.1 KiB
Racket
#lang racket/base
|
|
(require sugar
|
|
txexpr/base
|
|
racket/list
|
|
racket/string
|
|
pollen/setup
|
|
xml
|
|
html
|
|
racket/match
|
|
"html.rkt"
|
|
pollen/unstable/typography
|
|
net/url
|
|
racket/port)
|
|
|
|
(module+ test
|
|
(require rackunit))
|
|
|
|
(define (attrs->pollen-attrs attrs)
|
|
(string-join (for*/list ([attr (in-list attrs)]
|
|
[k (in-value (car attr))]
|
|
[v (in-value (cadr attr))])
|
|
(format "#:~a ~v" k v)) " "))
|
|
|
|
(define/contract+provide (xexpr->pollen x #:white-p? [white-p? #f])
|
|
((xexpr?) (#:white-p? boolean?) . ->* . string?)
|
|
(let loop ([x x])
|
|
(cond
|
|
[(and white-p? (txexpr? x) (eq? (car x) 'p) (empty? (get-attrs x))
|
|
(string-append* (list* (setup:paragraph-separator) (map ->string (map loop (get-elements x))))))]
|
|
[(and (txexpr? x)
|
|
(or (not (empty? (get-attrs x)))
|
|
(not (empty? (get-elements x)))))
|
|
(string-append* (map ->string `(,(setup:command-char)
|
|
,(get-tag x)
|
|
,@(if (pair? (get-attrs x)) `("[" ,(attrs->pollen-attrs (get-attrs x)) "]") null)
|
|
,@(if (pair? (get-elements x)) `("{" ,@(map loop (get-elements x)) "}" ) null))))]
|
|
[(txexpr? x) ; no attrs or tag, so needs parens
|
|
(format "~a(~a)" (setup:command-char) (get-tag x))]
|
|
[(symbol? x) (loop (entity->integer x))]
|
|
[(number? x) (format "~a" (integer->char x))]
|
|
[else x])))
|
|
|
|
(module+ test
|
|
(check-equal? (xexpr->pollen '(p "You are puppy")) "◊p{You are puppy}")
|
|
(check-equal? (xexpr->pollen '(div (p "You are puppy") (p "You are kitty"))) "◊div{◊p{You are puppy}◊p{You are kitty}}")
|
|
(check-equal? (xexpr->pollen #:white-p? #t '(div (p "You are puppy") (p "You are kitty"))) "◊div{
|
|
|
|
You are puppy
|
|
|
|
You are kitty}")
|
|
(check-equal? (xexpr->pollen '(p ((class "foo")) "You are puppy")) "◊p[#:class \"foo\"]{You are puppy}")
|
|
(check-equal? (xexpr->pollen '(p)) "◊(p)")
|
|
(check-equal? (xexpr->pollen '(p ((class "foo")) "You are " (em "so") " puppy")) "◊p[#:class \"foo\"]{You are ◊em{so} puppy}"))
|
|
|
|
(define (conjoin . fs)
|
|
(λ (x) (andmap (λ (f) (f x)) fs)))
|
|
|
|
(define/contract+provide (html->xexpr . html-strings)
|
|
(() () #:rest (listof string?) . ->* . xexpr?)
|
|
(use-html-spec #f)
|
|
(define html-string (string-join html-strings ""))
|
|
(define xexpr-results
|
|
; loop result will be a list with whitespace elements, so strip those out
|
|
(filter-not (conjoin string? whitespace?)
|
|
(let loop ([elem (read-html-as-xml (open-input-string html-string))])
|
|
(match elem
|
|
[(struct pcdata (start stop string)) string]
|
|
[(struct entity (start stop entity)) entity]
|
|
[(struct attribute (start stop key value)) (list key value)]
|
|
[(struct element (start stop name attributes content)) `(,name ,@(if (empty? attributes) empty (list (map loop attributes))) ,@(map loop content))]
|
|
[(list elements ...) (map loop elements)]
|
|
[else (format "unknown item: ~a" elem)]))))
|
|
(if (pair? xexpr-results) (car xexpr-results) ""))
|
|
|
|
(module+ test
|
|
(define (hx-identity xexpr)
|
|
(equal? (html->xexpr (xexpr->html xexpr)) xexpr))
|
|
(check-true (hx-identity '(p "You are puppy")))
|
|
(check-true (hx-identity '(p ((class "foo")) "You are puppy")))
|
|
(check-true (hx-identity '(p)))
|
|
(check-true (hx-identity '(p ((class "foo")) "You are " (em "so") " puppy")))
|
|
(check-equal? (html->xexpr "\n") ""))
|
|
|
|
|
|
(define/contract+provide (html->pollen #:white-p? [white-p? #f] . html-strings)
|
|
(() (#:white-p? boolean?) #:rest (listof string?) . ->* . string?)
|
|
(xexpr->pollen #:white-p? white-p? (apply html->xexpr html-strings)))
|
|
|
|
|
|
(define/contract+provide (url->pollen url-or-string #:white-p? [white-p? #f])
|
|
(((or/c string? url?)) (#:white-p? boolean?) . ->* . string?)
|
|
(define url (if (string? url-or-string) (string->url url-or-string) url-or-string))
|
|
(define url-result (port->string (get-pure-port url)))
|
|
(html->pollen url-result #:white-p? white-p?))
|