;;; (boudin schmaltz) --- transform almost-html plus scheme into html

;;; Embedded scheme code

(define (->string x)
  (call-with-port (open-output-string)
    (lambda (port)
      (display x port)
      (get-output-string port))))

(define render-string
  (case-lambda
    ((s) (render-string s (interaction-environment)))
    ((s env)
     (call-with-port (open-input-string s)
       (lambda (port)
         (render port env))))))

(define (render port env)
  ;; A few rough edges:
  ;; #, x will try to render x
  (define (burn-char)
    ;; Throw a character away.  I've defined this for clarity below.
    (read-char port))

  (let loop ((ch (read-char port))
             (acc '()))
    (define (proceed) (loop (read-char port) (cons ch acc)))
    (cond
     ((not ch)
      (loop (read-char port) acc))
     ((eof-object? ch)
      (list->string (reverse acc)))
     ((eq? ch #\#)                      ; special processing to come
      (case (peek-char port)
        ((#\\)                          ; inhibit processing of the next char
         (burn-char)
         (loop (read-char port) (cons ch acc)))
        ((#\,)                          ; scheme eval expansion
         (burn-char)
         (loop #f
               (append (let ((s (->string
                                 (eval (read port)
                                       env))))
                         (cond
                          ((equal? s "#<unspecified>") ; XXX NOT PORTABLE
                           '())
                          ((equal? s "#!eof") ; XXX NOT PORTABLE
                           '(#\, #\#))
                          (else (reverse (string->list s)))))
                       acc)))
        ((#\@)                          ; embedded sxml
         (burn-char)
         (loop #f
               (append (let ((h (eval `(sxml->html ,(list 'quasiquote
                                                          (read port)))
                                      env)))
                         (cond
                          ((equal? h "#!eof") ; XXX NOT PORTABLE
                           '(#\@ #\#))
                          (else (reverse (string->list h)))))
                       acc)))
        (else (proceed))))
     (else (proceed)))))

;;; Wrap paragraphs

(define (split-paragraphs str)
  (let loop ((lines (string-split str "\n"))
             (par '())
             (acc '()))
    (cond
     ((and (null? lines)                ; base case: no more lines
           (null? par))                 ; ... or pending paragraph
      (reverse acc))
     ((null? lines)                     ; add the final paragraph
      (loop '() '() (cons (apply string-append (reverse par)) acc)))
     ((equal? (car lines) "")           ; paragraph break
      (loop (cdr lines)
            '()
            (cons (apply string-append (reverse par)) acc)))
     (else                              ; line break
      (loop (cdr lines)
            (cons (string-append (car lines) "\n") par)
            acc)))))

(define (wrap-paragraphs str)
  (let loop ((pars (split-paragraphs str))
             (acc '()))
    (cond
     ((null? pars)
      (apply string-append (reverse acc)))
     ((zero? (string-length (car pars)))
      (loop (cdr pars)
            acc))
     ((eq? #\< (string-ref (string-trim (car pars)) 0))
      (loop (cdr pars)
            (cons (car pars)
                  acc)))
     (else
      (loop (cdr pars)
            (cons (string-append "<p>" (car pars) "</p>\n")
                  acc))))))