common.ss
#lang scheme/base

(require scribble/manual
         scribble/struct
         scribble/decode
         scribble/bnf
         scribble/scheme
         (for-label scheme/base
                    scribble/manual
                    scribble/decode
                    scribble/struct
                    scribble/eval))
(provide (all-from-out scribble/manual
                       scribble/bnf
                       scribble/decode)
         (for-label (all-from-out scheme/base
                                  scribble/manual
                                  scribble/decode
                                  scribble/struct
                                  scribble/eval)))

(provide code-block
         code-elem
         scr:code-block
         scr:code-elem
         ~cite citet
         nested
         lit
         fake-section
         abstract
         htdp-lambda
         latex
         slatex
         figure)

(define (read-all-syntaxes str read)
  (with-handlers ([void (lambda (e)
                          (fprintf (current-error-port)
                                   "READ ERROR: ~a\nwhile reading:\n~a\n"
                                   (exn-message e) str)
                          '())])
    (parameterize ([current-input-port (open-input-string str)])
      (port-count-lines! (current-input-port))
      (let loop ()
        (let ([stx (read)])
          (if (eof-object? stx) '() (cons stx (loop))))))))

;; collect all identifiers, ignores un-original ids and non-identifiers
(define (get-identifiers x)
  (let loop ([x x] [acc null])
    (cond [(identifier? x) (if (syntax-original? x) (cons x acc) acc)]
          [(syntax? x) 
           (let* ([v (syntax-e x)]
                  [acc
                   (cond
                    [(string? v) 
                     (if (syntax-property x 'scribble)
                         acc
                         (cons x acc))]
                    [(number? v) (cons x acc)]
                    [(boolean? v) (cons x acc)]
                    [else acc])])
             (loop (syntax-e x) acc))]
          [(pair? x) (loop (car x) (loop (cdr x) acc))]
          [(null? x) acc]
          [else acc])))

(define (decorate-id id)
  (to-element (datum->syntax #'here (syntax-e id))))

(define (decorate-identifier id str)
  (cond
   [(identifier? id)
    (if (char=? #\@ (string-ref str 0))
        (make-element #f (list (tt "@") (decorate-id id)))
        (decorate-id id))]
   [(string? (syntax-e id))
    (schemevalfont str)]
   [else
    (to-element id)]))

(define (read-syntax*)
  (parameterize ([read-accept-reader #t]) (read-syntax)))

(define (expr-decorate strs #:reader [reader read-syntax*])
  (let* ([str (apply string-append strs)]
         [ids (sort (get-identifiers (read-all-syntaxes str reader))
                    < #:key syntax-position)]
         [len (string-length str)])
    (let loop ([i 0] [ids ids])
      (if (null? ids)
        (if (= i len) '() (list (substring str i)))
        (let* ([id (car ids)]
               [pos (sub1 (syntax-position id))]
               [span (syntax-span id)])
          (cond [(pos . < . i)
                 (loop i (cdr ids))
                 #;
                 (error 'expr-decorate "nested identifiers found in: ~e at: ~e" str (syntax->datum id))]
                [(pos . > . i)
                 (cons (substring str i pos) (loop pos ids))]
                ;; pos = i
                [else (cons (decorate-identifier
                             id (substring str pos (+ i span)))
                            (loop (+ pos span) (cdr ids)))]))))))

(define (split-lines l)
  (let loop ([l l][so-far null])
    (cond
     [(null? l) (if (null? so-far)
                    null
                    (cons (reverse so-far) null))]
     [(equal? (car l) "\n")
      (cons (reverse so-far) (loop (cdr l) null))]
     [(and (string? (car l))
           (regexp-match #rx"(.*)\n(.*)" (car l)))
      => (lambda (m)
           (loop (list* (cadr m)
                        "\n"
                        (caddr m)
                        (cdr l))
                 so-far))]
     [(and (string? (car l))
           (regexp-match #rx"(.*)(#lang [a-z/]+)(.*)" (car l)))
      => (lambda (m)
           (loop (list* (cadr m)
                        (tt (caddr m))
                        (cadddr m)
                        (cdr l))
                 so-far))]
     [(and (string? (car l))
           (regexp-match #rx"(.*)( +)(.*)" (car l)))
      => (lambda (m)
           (loop (list* (cadr m)
                        (hspace (string-length (caddr m)))
                        (cadddr m)
                        (cdr l))
                 so-far))]
     [(equal? (car l) "")
      (loop (cdr l) so-far)]
     [else (loop (cdr l) (cons (car l) so-far))])))

(define (maybe-tt s)
  (if (string? s)
      (schemeparenfont s)
      s))

(define (code-block #:reader [reader read-syntax*] . strs)
  (make-table
   #f
   (map
    (lambda (l)
      (list (make-flow (list (make-paragraph (cons (hspace 1) (map maybe-tt l)))))))
    (split-lines (expr-decorate #:reader reader strs)))))

(define (code-elem #:reader [reader read-syntax*] . strs)
  (make-element
   #f
   (map maybe-tt 
        (car
         (split-lines
          (expr-decorate #:reader reader
                         (map (lambda (str) (regexp-replace #rx"\n" str " "))
                              strs)))))))

;; convenient utils -- use the scribble reader
(require (only-in scribble/reader [read-syntax scr:read-syntax]))
(define (scr:code-block . strs)
  (keyword-apply code-block '(#:reader) (list scr:read-syntax) strs))
(define (scr:code-elem . strs)
  (keyword-apply code-elem '(#:reader) (list scr:read-syntax) strs))

(define (~cite str)
  (make-element #f
                (list 'nbsp (make-element "cite" (list str)))))
(define (citet str)
  (make-element "citet" (list str)))

(define (nested . str)
  (make-blockquote #f (flow-paragraphs (decode-flow str))))

(define (lit str)
  (make-element 'tt (list str)))

(define (fake-section . str)
  (make-splice
   (list
    (apply bold "1" (hspace 2) str)
    (make-element "vspace" (list "1ex")))))

(define (abstract . strs)
  (make-blockquote
   "abstract"
   (flow-paragraphs
    (decode-flow strs))))

(define-syntax-rule (htdp-lambda)
  (begin
    (require (for-label lang/htdp-beginner))
    (scheme lambda)))

(define latex (make-element "latexName" '("LaTeX")))
(define slatex (make-element "slatexName" '("SLaTeX")))

(define (figure img . str)
  (make-blockquote
   "centerfigure"
   (list
    (make-paragraph
     (list (image #:scale 0.5 img)))
    (make-paragraph
     (list
      (make-element "caption"
                    (decode-content str)))))))