show-help.rkt

#lang racket
(require racket/gui)

(provide show-help)

(define show-help 
  (lambda (collections frame-title [verbatim? #f])
    (let* ([f #f]
           [f%
            (class frame%
              (define/augment (on-close)
                (set! f #f))
              (super-instantiate () (label frame-title)))])
      (lambda ()
        (if f
            (send f show #t)
            (let* ([frame (make-object f%)]
                   [t (make-object text%)]
                   [c (new editor-canvas% [parent frame] [editor t] [style '(auto-hscroll)])])
              (send c min-width 500)
              (send c min-height 300)
              (send t auto-wrap (not verbatim?))
              (call-with-input-file (build-path
                                     (apply collection-path collections)
                                     "doc.txt")
                (lambda (p)
                  (let loop ()
                    (let ([l (read-line p)])
                      (unless (eof-object? l)
                        (cond
                          [verbatim?
                           (send t insert l)
                           (send t insert #\newline)]
                          [(regexp-match #rx"^[*][*].*[*][*]$" l)
                           ;; Skip
                           (void)]
                          [(string=? l "")
                           (unless (zero? (send t last-position))
                             (send t insert #\newline)
                             (send t insert #\newline))]
                          [(and (regexp-match #rx"^-+$" l)
                                (= (string-length l) 
                                   (- (send t last-position)
                                      (send t paragraph-start-position (send t last-paragraph))
                                      1)))
                           ;; Change previous line style to title
                           (let ([end (send t last-position)])
                             (send t change-style 
                                   (send (make-object style-delta% 'change-weight 'bold)
                                         set-delta-foreground
                                         "blue")
                                   (- end 1 (string-length l)) (- end 1)))]
                          [else
                           (let ([l (regexp-replace #rx" +$" 
                                                    (regexp-replace #rx"^ +" l "")
                                                    "")])
                             (send t insert l)
                             (when (regexp-match #rx"^[*]" l)
                               (send t set-paragraph-margins
                                     (send t position-paragraph (send t last-position))
                                     16 32 0))
                             (send t insert #\space))])
                        (loop)))))
                #:mode 'text)
              (when verbatim?
                (send t change-style 
                      (make-object style-delta% 'change-family 'modern)
                      0 (send t last-position)))
              (send t lock #t)
              (send t set-position 0 0)
              (send frame show #t)
              (set! f frame)))))))