#lang scheme/base

(require scribble/manual
         scribble/struct
         scribble/decode
         scribble/bnf
         scribble/scheme
         "bib.ss"
         "counter.ss"
         (for-label scheme/base
                    scribble/manual
                    scribble/decode
                    scribble/struct
                    scribble/eval
                    scribble/srcdoc
                    scribble/extract
                    (only-in slideshow pict? circle)
                    scribblings/quick/mreval
                    scribble/lp
                    scribble/lp-include))
(provide (all-from-out scribble/manual
                       scribble/bnf
                       scribble/decode
                       "bib.ss")
         (for-label (all-from-out scheme/base
                                  scribble/manual
                                  scribble/decode
                                  scribble/struct
                                  scribble/eval
                                  scribble/srcdoc
                                  scribble/extract
                                  slideshow
                                  scribble/lp
                                  scribble/lp-include)))

(provide no-indent
         show-link
         code-block
         code-block/file
         code-elem
         scr:code-block
         scr:code-elem
         ~cite citet
         nested
         lit
         fake-section
         abstract
         quoted
         next-line
         htdp-circle
         latex
         slatex
         attribution
         fixitemtab
         imgfigure
         imgfigure*
         figure
         figure*
         figure**
         minipage
         lp-minipage
         Figure-target Figure-ref
         html-author)

(define no-indent
  (make-element "NoIndent" null))

(define (show-link url)
  (link url (elem #:style "url" url)))

(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 str)
  (to-element (make-just-context (datum->syntax #f (string->symbol str))
                                 (datum->syntax #'here (syntax-e id)))))

(define (decorate-identifier id str)
  (cond
   [(equal? str "'") str]
   [(identifier? id)
    (if (char=? #\@ (string-ref str 0))
        (make-element #f (list (tt "@") (decorate-id id (substring str 1))))
        (decorate-id id str))]
   [(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)]
         [lang-line (regexp-match #rx"^#lang [^\r\n]*" str)])
    (append
     (if lang-line
         (cons (hash-lang)
               (apply
                append
                (map 
                 (lambda (str)
                   (list " "
                         (schememodname #,(string->symbol str))))
                 (cdr (regexp-match* #rx"[-#a-z/0-9]*" (car lang-line))))))
         null)
     (let loop ([i (if lang-line (string-length (car lang-line)) 0)] 
                [ids (if lang-line (cdr 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 (+ pos 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)
                        (let ([len (string-length (caddr m))])
                          (if (= len 1)
                              (make-element 'tt (list " ")) ; to allow line breaks
                              (hspace len)))
                        (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)
      (let ([m (regexp-match #rx"^(.*)@(.*)$" s)])
        (if m
            (make-element #f (list (maybe-tt (cadr m))
                                   (tt "@")
                                   (maybe-tt (caddr m))))
            (schemeparenfont s)))
      s))

(define (code-block #:reader [reader read-syntax*] . strs)
  (make-table
   "CodeBlock"
   (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)))))))

(define (code-block/file filename)
  (code-block
   (apply string-append
          (call-with-input-file filename
            (lambda (port)
              (let loop ()
                (let ([line (read-line port 'any)])
                  (if (eof-object? line)
                      '()
                      (list* line "\n" (loop))))))))))


;; 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 (nested . str)
  (make-blockquote "Nested" (list (make-blockquote "NestedInside" (flow-paragraphs (decode-flow str))))))

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

(define (fake-section . str)
  (apply bold "1" (hspace 2) str))

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

(define (quoted . strs)
  (make-blockquote
   #f
   (flow-paragraphs
    (decode-flow strs))))

(define (next-line) (make-element "NextLine" null))

(define-syntax-rule (htdp-circle)
  (begin
    (require (for-label teachpack/htdp/image))
    (scheme circle)))

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

(define (fixitemtab . content)
  (make-blockquote
   "fixitemtab"
   (flow-paragraphs
    (decode-flow content))))

(define (attribution . content)
  (make-styled-paragraph (decode-content content) "Attribution"))

(define (*imgfigure style img str scale)
  (make-blockquote
   style
   (list
    (make-paragraph
     (list (image #:scale scale img)))
    (make-paragraph
     (list
      (make-element "Legend"
                    (decode-content str)))))))

(define (imgfigure img #:scale [scale 0.5] . str)
  (*imgfigure "centerfigure" img str scale))
(define (imgfigure* img #:scale [scale 0.5] . str)
  (*imgfigure "centerfigureMulti" img str scale))

(define (figure tag caption . content)
  (make-blockquote
   "centerfigure"
   (list
    (make-blockquote
     "figureInside"
     (append
      (flow-paragraphs
       (decode-flow content))
      (list
       (make-paragraph
        (list
         (make-element "Legend"
                       (list* (Figure-target tag) ": " 
                              (decode-content (list caption))))))))))))

(define (*figure style tag caption content)
  (make-blockquote
   style
   (list
    (make-blockquote
     "figureInside"
     (append
      (flow-paragraphs
       (decode-flow content))
      (list
       (make-paragraph
        (list
         (make-element "Legend"
                       (list* (Figure-target tag) ": " 
                              (decode-content (list caption))))))))))))

(define (figure* tag caption . content)
  (*figure "centerfigureMulti" tag caption content))
(define (figure** tag caption . content)
  (*figure "centerfigureMultiWide" tag caption content))

(define (lp-minipage . content)
  (make-blockquote
   "LPminipage"
   (flow-paragraphs
    (decode-flow content))))

(define (minipage . content)
  (make-blockquote
   "Minipage"
   (flow-paragraphs
    (decode-flow content))))

(define figures (new-counter "figure"))
(define (Figure-target tag)
  (counter-target figures tag "Figure"))
(define (Figure-ref tag)
  (make-element #f (list (counter-ref figures tag "Figure"))))

(define (html-author . names)
  (make-blockquote "HTMLAuthors" (list (apply author names))))