#lang scheme/base

(require scribble/struct
         scribble/manual
         (prefix-in scheme: scribble/scheme)
         (prefix-in scribble: scribble/reader))

(define-syntax bounce-for-label
  (syntax-rules (all-except)
    [(_ (all-except mod (id ...) (id2 ...)))
     (begin (require (for-label (except-in mod id ...)))
            (provide (for-label (except-out (all-from-out mod) id2 ...))))]
    [(_ mod) (begin (require (for-label mod))
                    (provide (for-label (all-from-out mod))))]
    [(_ mod ...) (begin (bounce-for-label mod) ...)]))

(bounce-for-label (all-except scheme (link) ())
                  scribble/struct
                  scribble/base-render
                  scribble/decode
                  scribble/manual
                  scribble/scheme
                  scribble/eval
                  scribble/bnf)

(provide scribble-examples litchar/lines)

(define (as-flow e)
  (make-flow (list (if (block? e) e (make-paragraph (list e))))))

(define (litchar/lines . strs)
  (let ([strs (regexp-split #rx"\n" (apply string-append strs))])
    (if (= 1 (length strs))
      (litchar (car strs))
      (make-table
       #f
       (map (lambda (s) ; the nbsp is needed for IE
              (list (as-flow (if (string=? s "") 'nbsp (litchar s)))))
            strs)))))

(define spacer (hspace 2))

(define ((norm-spacing base) p)
  (cond [(and (syntax->list p) (not (null? (syntax-e p))))
         (let loop ([e (syntax->list p)]
                    [line (syntax-line (car (syntax-e p)))]
                    [pos base]
                    [second #f]
                    [accum null])
           (if (null? e)
             (datum->syntax
              p (reverse accum)
              (list (syntax-source p) (syntax-line p) base (add1 base)
                    (- pos base))
              p)
             (let* ([v ((norm-spacing (if (= line (syntax-line (car e)))
                                        pos
                                        (or second pos)))
                        (car e))]
                    [next-pos (+ (syntax-column v) (syntax-span v) 1)])
               (loop (cdr e)
                     (syntax-line v)
                     next-pos
                     (or second next-pos)
                     (cons v accum)))))]
        [else (datum->syntax
               p (syntax-e p)
               (list (syntax-source p) (syntax-line p) base (add1 base) 1)
               p)]))

(define (scribble-examples . lines)
  (define reads-as (make-paragraph (list spacer "reads as" spacer)))
  (let* ([lines (apply string-append lines)]
         [p (open-input-string lines)])
    (port-count-lines! p)
    (let loop ([r '()] [newlines? #f])
      (regexp-match? #px#"^[[:space:]]*" p)
      (let* ([p1  (file-position p)]
             [stx (scribble:read-syntax #f p)]
             [p2  (file-position p)])
        (if (not (eof-object? stx))
          (let ([str (substring lines p1 p2)])
            (loop (cons (list str stx) r)
                  (or newlines? (regexp-match? #rx#"\n" str))))
          (let* ([r (reverse r)]
                 [r (if newlines?
                      (cdr (apply append (map (lambda (x) (list #f x)) r)))
                      r)])
            (make-table
             #f
             (map (lambda (x)
                    (let ([@expr (if x (litchar/lines (car x)) "")]
                          [sexpr (if x
                                   (scheme:to-paragraph
                                    ((norm-spacing 0) (cadr x)))
                                   "")]
                          [reads-as (if x reads-as "")])
                      (map as-flow (list spacer @expr reads-as sexpr))))
                  r))))))))

;; stuff for the preprocessor examples

(require scheme/list (for-syntax scheme/base scheme/list))

(define max-textsample-width 35)

(define (textsample-verbatim-boxes line 1st 2nd more)
  (define (split str) (regexp-split #rx"\n" str))
  (define strs1 (split 1st))
  (define strs2 (split 2nd))
  (define strsm (map (compose split cdr) more))
  (define (str->elts str)
    (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
      (if spaces
        (list* (substring str 0 (caar spaces))
               (hspace (- (cdar spaces) (caar spaces)))
               (str->elts (substring str (cdar spaces))))
        (list (make-element 'tt (list str))))))
  (define (make-line str) (list (as-flow (make-element 'tt (str->elts str)))))
  (define (make-box strs) (make-table 'boxed (map make-line strs)))
  (define box1 (make-box strs1))
  (define box2 (make-box strs2))
  (define boxm (map make-box strsm))
  (define filenames (map car more))
  (define indent (let ([d (- max-textsample-width
                             (for*/fold ([m 0])
                                        ([s (in-list (cons strs1 strsm))]
                                         [s (in-list s)])
                               (max m (string-length s))))])
                   (if (negative? d)
                     (error 'textsample-verbatim-boxes
                            "left box too wide for sample at line ~s" line)
                     (hspace d))))
  (values
   (make-table '([alignment right left] [valignment top top])
     (cons (list (as-flow indent) (as-flow box1))
           (map (lambda (file strs)
                  (let* ([file (make-element 'tt (list file ":" 'nbsp))]
                         [file (list (make-element 'italic (list file)))])
                    (list (as-flow (make-element '(bg-color 232 232 255) file))
                          (as-flow (make-box strs)))))
                filenames strsm)))
   box2))

(define (textsample line 1st 2nd . more)
  (define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd more))
  (make-table '([alignment left left left] [valignment center center center])
    (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2)))))

(define-for-syntax tests-ids #f)

(provide initialize-tests)
(define-syntax (initialize-tests stx)
  (set! tests-ids (map (lambda (x) (datum->syntax stx x stx))
                       '(tests add-to-tests)))
  (with-syntax ([(tests add-to-tests) tests-ids])
    #'(begin (provide tests)
             (define-values (tests add-to-tests)
               (let ([l '()])
                 (values (lambda () (reverse l))
                         (lambda (x) (set! l (cons x l)))))))))

(provide example)
(define-syntax (example stx)
  (define sep-rx  #px"^---[*]{3}---(?: +(.*))?$")
  (define file-rx #rx"^[a-z0-9_.+-]+$")
  (syntax-case stx ()
    [(_ x ...)
     (let loop ([xs #'(x ...)] [text '(#f)] [texts '()])
       (syntax-case xs ()
         [("\n" sep "\n" . xs)
          (and (string? (syntax-e #'sep))
               (regexp-match? sep-rx (syntax-e #'sep)))
          (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr]
                         [else #f])])
            (if (and m (not (regexp-match? file-rx m)))
              (raise-syntax-error #f "bad filename specified" stx #'sep)
              (loop #'xs
                    (list (and m (datum->syntax #'sep m #'sep #'sep)))
                    (cons (reverse text) texts))))]
         [(x . xs) (loop #'xs (cons #'x text) texts)]
         [() (let ([texts (reverse (cons (reverse text) texts))]
                   [line  (syntax-line stx)])
               (define-values (files i/o) (partition car texts))
               (unless ((length i/o) . = . 2)
                 (raise-syntax-error
                  'example "need at least an input and an output block" stx))
               (with-syntax ([line  line]
                             [((i/o ...) ...) (map cdr i/o)]
                             [((file text ...) ...) files]
                             [add-to-tests (cadr tests-ids)])
                 (syntax/loc stx
                   (let ([t (list line (string-append i/o ...) ...
                                  (cons file (string-append text ...)) ...)])
                     (add-to-tests t)
                     (apply textsample t)))))]
         [_ (raise-syntax-error #f "no separator found in example text")]))]))