pollen/scribblings/utils.rkt

#lang racket/base

(require scribble/core
         scribble/html-properties
         scribble/manual
         (prefix-in racket: scribble/racket)
         (prefix-in scribble: scribble/reader)
         (prefix-in pollen: (submod pollen 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 racket (abstract link) ())
                  scribble/core
                  scribble/base-render
                  scribble/decode
                  scribble/manual
                  scribble/racket
                  scribble/html-properties
                  scribble/latex-properties
                  scribble/eval
                  scribble/bnf)

(provide scribble-examples pollen-examples litchar/lines doc-render-examples)

(define (as-flow e)
  (if (block? e) e (make-paragraph plain (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
       plain
       (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 (pollen-examples . lines)
  (define reads-as (make-paragraph plain (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 (pollen: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
             plain
             (map (lambda (x)
                    (let ([@expr (if x (litchar/lines (car x)) "")]
                          [sexpr (if x
                                   (racket:to-paragraph
                                    ((norm-spacing 0) (cadr x)))
                                   "")]
                          [reads-as (if x reads-as "")])
                      (map as-flow (list spacer @expr reads-as sexpr))))
                  r))))))))


(define (scribble-examples . lines)
  (define reads-as (make-paragraph plain (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
             plain
             (map (lambda (x)
                    (let ([@expr (if x (litchar/lines (car x)) "")]
                          [sexpr (if x
                                   (racket: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 scribble/text examples

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

(define max-textsample-width 45)

(define (textsample-verbatim-boxes line in-text out-text more)
  (define (split str) (regexp-split #rx"\n" str))
  (define strs1 (split in-text))
  (define strs2 (split out-text))
  (define strsm (map (compose split cdr) more))
  (define (str->elts str)
    (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
      (if spaces
        (list* (str->elts (substring str 0 (caar spaces)))
               (smaller (hspace (- (cdar spaces) (caar spaces))))
               (str->elts (substring str (cdar spaces))))
        (list (smaller (make-element 'tt str))))))
  (define (make-line str)
    (list (as-flow (if (equal? str "")
                       (smaller (hspace 1))
                       (str->elts str)))))
  (define (make-box strs [file #f])
    (nested #:style 'code-inset
            (let ([t (make-table plain (map make-line strs))])
              (if file
                  (filebox file t)
                  t))))
  (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)
                     (make-element 'tt (list (hspace d))))))
  ;; Note: the font-size property is reset for every table, so we need it
  ;; everywhere there's text, and they don't accumulate for nested tables
  (values
   (make-table 
     (make-style #f
                 (list (make-table-columns (list (make-style #f '(left top))))))
     (cons (list (as-flow (make-box strs1)))
           (map (lambda (file strs)
                  (list (as-flow (make-box strs file))))
                filenames strsm)))
   (make-box strs2)))

(define (textsample line in-text out-text more)
  (define-values (box1 box2)
    (textsample-verbatim-boxes line in-text out-text more))
  (make-table 
   (make-style #f (list (make-table-columns (list (make-style #f '(left vcenter))
                                                  (make-style "Short" '(left vcenter))
                                                  (make-style #f '(left vcenter))))))
    (list (map as-flow (list box1 (make-paragraph plain '(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_.+-]+$")
  (define-values (body hidden?)
    (syntax-case stx ()
      [(_ #:hidden x ...) (values #'(x ...) #t)]
      [(_          x ...) (values #'(x ...) #f)]))
  (let loop ([xs body] [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]
                          [((in ...) (out ...)) (map cdr i/o)]
                          [((file text ...) ...) files]
                          [add-to-tests (cadr tests-ids)])
              (quasisyntax/loc stx
                (let* ([in-text  (string-append in ...)]
                       [out-text (string-append out ...)]
                       [more (list (cons file (string-append text ...)) ...)])
                  (add-to-tests (list line in-text out-text more))
                  #,(if hidden? #'""
                        #'(textsample line in-text out-text more))))))]
      [_ (raise-syntax-error #f "no separator found in example text")])))

(provide ltx ltxe ltxd)
(define (ltx s) (tt "\\" s)) ; command
(define (ltxe s) (tt s)) ; enviornment
(define (ltxd n s)
  (make-element #f (cons (index (list s) (ltx s))
                         (for/list ([i (in-range n)]) (tt "{}")))))

;; Utility to render examples of scribble documentation forms
;; Note: it would be nice if this abstracted over the codeblock
;;       that usually comes along with this too, but that's hard
;;       because there's a read-time distinction between [...]
;;       and |{...}|.
(define-syntax-rule (doc-render-examples e ...)
  (nested "Renders like:\n"
          (nested #:style 'inset (nested #:style 'inset e ...))))