/prog/ - S-Expressions to HTML

Name: Anonymous 2012-09-23 16:57

(define (tagged-list? expr)

  (and (pair? expr) (symbol? (car expr))))



(define (sexp->html expr)

  (cond ((null? expr) "")

        ((string? expr) expr)

        ((tagged-list? expr)

         (make-element (symbol->string (car expr)) "" (cdr expr)))

        ((pair? expr)

         (string-append (sexp->html (car expr))

                        (sexp->html (cdr expr))))

        (else (error "cannot be converted to html" expr))))



(define (make-element name attrs expr)

  (cond ((null? expr) (string-append "<" name attrs "/>"))

        ((tagged-list? expr)

         (make-element name

                       (string-append attrs

                                      " " (symbol->string (car expr))

                                      "=\"" (cadr expr) "\"")

                       (cddr expr)))

        (else

          (string-append "<" name attrs ">" (sexp->html expr) "</" name ">"))))

Sample input:

(let ((title "Hello, world!")

      (urls '("https://boards.4chan.org/g/"

              "https://www.reddit.com/r/programming"

              "https://news.ycombinator.com")))

  (display

    (sexp->html

      `(html lang "en-us"

             (head

               (meta charset "utf-8")

               (title ,title)

               (style type "text/css"

                      "o { text-decoration: overline; }"

                      "spoiler { background-color: #000; }"

                      "spoiler:hover { background-color: transparent; }"))

             (body 

               (h1 ,title)

               (p "Welcome to " (spoiler "/prog/") "." (br)

                  (b (i (o (u "ENTERPRISE")))) " solutions!")

               (h2 "Places you should go back to.")

               (ul ,(map (lambda (url) `(li (a href ,url ,url)))

                         urls)))))))

Output:
http://pastebin.com/v4cTnfTJ (spam filter won't let me post HTML)

Name: Anonymous 2012-09-23 19:57

ok, here it is. It's a bit long.



(define (lcar llis) (car llis))

(define (lcdr llis) (force (cdr llis)))



;; There doesn't seem to be a promise? predicate...

;; This needs to be better.

(define (llist? lis)

  (pair? lis))



;; replace with define-syntax if not using an old scheme implementation 

(defmacro (lcons first rest)

  `(cons ,first (delay ,rest)))



(define (list->llist lis)

  (if (null? lis)

    '()

    (lcons (car lis)

           (list->llist (cdr lis)))))



(define (llist . lis)

  (list->llist lis))



(define (llist->list llis)

  (letrec ((unroller (lambda (llis acc)

                       (if (null? llis)

                         (reverse acc)

                         (unroller (lcdr llis)

                                   (cons (lcar llis)

                                         acc))))))

    (unroller llis '())))



(define (lappend llises)

  (if (null? llises)

      '()

      (let ((first-llises (lcar llises))

            (rest-llises (lcdr llises)))

        (if (null? first-llises)

           (lappend rest-llises)

           (lcons (lcar first-llises)

                  (lappend (lcons (lcdr first-llises)

                                  rest-llises)))))))



(define (lmap1 fn llis)

  (if (null? llis)

    '()

    (lcons (fn (lcar llis))

           (lmap1 fn (lcdr llis)))))



(define (lfor-each proc llis)

  (if (not (null? llis))

    (begin (proc (lcar llis))

           (lfor-each proc (lcdr llis)))))



(define (tree->ltree tre)

  (if (list? tre)

    (list->llist (map tree->ltree tre))

    tre))



(define (flatten-ltree ltre)

  (if (llist? ltre)

    (lappend (lmap1 flatten-ltree ltre))

    (llist ltre)))



(define (test)

  (let ((data '((((test test test)

                  test

                  (test test)

                  data

                  (data data (test)))

                 (nested data test)

                 test)

                (data data data test test (t) (((t))) (t test test)))))

    (display (apply string-append

                    (llist->list (lmap1 symbol->string

                                        (flatten-ltree (tree->ltree data))))))))



(test)

S-Expressions to HTML

1 Name: Anonymous 2012-09-23 16:57

25 Name: Anonymous 2012-09-23 19:57

Name: Anonymous 2012-09-23 16:57

Name: Anonymous 2012-09-23 19:57