markdown view demo

md-view.rkt

#lang racket
;; Markdown Viewer

;; Copyright (c) 2020 Alex Harsányi ([email protected])

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.#lang racket

(require racket/gui markdown)


;;............................................................... styles ....

;; Style used for the "base" text in the markdown viewer.  This style is used
;; when no other formatting is done (i.e. this is the default font and font
;; size used)
(define base-style
  (let ([delta (new style-delta%)])
    (send delta set-delta-face "Calibri")
    (send delta set-size-add 4)
    delta))

;; Style to mark "strong" or bold sections
(define strong-style
  (make-object style-delta% 'change-bold))

;; Style to mark "italic" or emphasis sections
(define em-style
  (make-object style-delta% 'change-style 'italic))

;; Style to mark "code" sections, using a monospaced font.
(define code-style
  (let ([delta (new style-delta%)])
    (send delta set-delta-face "Consolas")
    delta))

;; Create a header style using a font increase and a color.  This is used to
;; define the style used for headers (H1 to H6)
(define (make-header-style font-increase color)
  (let ([delta (make-object style-delta% 'change-bigger font-increase)])
    (send delta set-delta-background color)
    (send delta set-alignment-on 'base)
    (send delta set-underlined-on #t)
    delta))

;; The actual header styles
(define h1-style (make-header-style 5 (make-object color% 187 204 238)))
(define h2-style (make-header-style 4 (make-object color% 204 238 255)))
(define h3-style (make-header-style 3 (make-object color% 204 221 170)))
(define h4-style (make-header-style 2 (make-object color% 238 238 187)))
(define h5-style (make-header-style 2 (make-object color% 255 204 204)))
(define h6-style (make-header-style 2 (make-object color% 221 221 221)))

;; Style used for hyperlinks, when not clicked
(define hyperlink-style
  (let ([delta (make-object style-delta%)])
    (send delta set-delta-foreground (make-object color% 68 119 170))
    (send delta set-alignment-on 'base)
    (send delta set-underlined-on #t)
    delta))

;; Style used for hyperlinks when clicked on
(define hyperlink-clicked-style
  (let ([delta (make-object style-delta%)])
    (send delta set-delta-background (make-object color% 68 119 170))
    (send delta set-alignment-on 'base)
    (send delta set-underlined-on #t)
    delta))

;; Style used for blockquotes
(define blockquote-style
  (make-object style-delta% 'change-style 'slant))


;;............................................. Nesting and list control ....

;; Specifies the amount of nesting for the current paragraph (used by lists
;; and blockquotes)
(define paragraph-indent (make-parameter 0))
;; The list nesting level, or 0 if we are not in a list
(define list-nesting (make-parameter 0))
;; The number of the current list item, if inside an ordered list, #f if
;; inside an unordered one.
(define list-item 1)


;;...................................................... inserting items ....

;; Insert the TEXT into EDITOR and apply the list of STYLES to it.  Note that
;; the list of styles is applied in reverse.
(define (insert-and-apply-styles editor text styles)
  (let ((start (send editor last-position)))
    (send editor insert (make-object string-snip% text))
    (define end (send editor last-position))
    (for ([style (in-list (reverse styles))])
      (send editor change-style style start end #f))))

;; Insert a single markdown item using STYLE-LIST.  depending on the actual
;; item, new styles are added to this list and more specific insert functions
;; are called.  This is the main dispatch function, which knows how to insert
;; every markdown item type.
(define (insert-markdown-item editor item style-list)
  (cond  ((string? item)
          (insert-and-apply-styles editor item style-list))
         ((equal? item 'mdash)
          (insert-and-apply-styles editor "—" style-list))
         ((equal? item 'ldquo)
          (insert-and-apply-styles editor "“" style-list))
         ((equal? item 'rdquo)
          (insert-and-apply-styles editor "”" style-list))
         (#t
          (match-let ([(list-rest name attributes body) item])
            (case name
              ((p div)
               (when (equal? name 'p)
                 (insert-newline editor))
               (insert-markdown-items editor body style-list #t))
              ((strong)
               (insert-markdown-items editor body (cons strong-style style-list)))
              ((em)
               (insert-markdown-items editor body (cons em-style style-list)))
              ((code)
               (insert-markdown-items editor body (cons code-style style-list)))
              ((h1)
               (insert-markdown-items editor body (cons h1-style style-list) #t))
              ((h2)
               (insert-markdown-items editor body (cons h2-style style-list) #t))
              ((h3)
               (insert-markdown-items editor body (cons h3-style style-list) #t))
              ((h4)
               (insert-markdown-items editor body (cons h4-style style-list) #t))
              ((h5)
               (insert-markdown-items editor body (cons h5-style style-list) #t))
              ((h6)
               (insert-markdown-items editor body (cons h6-style style-list) #t))
              ((a)
               (define target (dict-ref attributes 'href #f))
               (insert-hyperlink editor body style-list (and target (car target))))
              ((img)
               (define image (dict-ref attributes 'src #f))
               (insert-image editor (and image (car image))))
              ((blockquote)
               (parameterize ([paragraph-indent (+ 20 (paragraph-indent))])
                 (insert-markdown-items editor body (cons blockquote-style style-list)) #t))
              ((ul ol)
               (when (zero? (list-nesting))
                 (insert-newline editor))
               (let ((old-list-item list-item))
                 (set! list-item (if (equal? name 'ol) 1 #f))
                 (parameterize ([list-nesting (add1 (list-nesting))])
                   (insert-markdown-items editor body style-list))
                 (set! list-item old-list-item))
               (when (zero? (list-nesting))
                 (insert-newline editor)))
              ((li)
               (insert-list-item editor body style-list)))))))

;; Insert a list of markdown ITEMS.  Start a new paragraph if PARAGRAPH?  is
;; `#t` and indent the first paragraph according to the indent level.
(define (insert-markdown-items editor items style-list (paragraph? #f))
  (when (and paragraph? (not (zero? (send editor last-position))))
    (insert-newline editor))
  (define paragraph (send editor last-paragraph))
  (for ([item (in-list items)])
    (insert-markdown-item editor item style-list))
  (when (and paragraph? (> (paragraph-indent) 0))
    (send editor set-paragraph-margins paragraph
          (paragraph-indent)
          (paragraph-indent)
          (paragraph-indent))))

;; Insert a hard newline into the editor -- this will delimit the paragraphs.
(define (insert-newline editor)
  (let ((s (make-object string-snip% "\n")))
    (send s set-flags (cons 'hard-newline (send s get-flags)))
    (send editor insert s)))

;; Insert a hyperlink.  ITEMS represent the text to be clicked on and it is
;; styled using STYLE-LIST plus the hyperlink-style, and TARGET is the
;; hyperlink URL
(define (insert-hyperlink editor items style-list target)
  (let ((start (send editor last-position)))
    (insert-markdown-items editor items (cons hyperlink-style style-list))
    (define end (send editor last-position))
    (send editor set-clickback
          start end
          (lambda (editor s e)
            (printf "Would follow URL: ~a~%" target)
            ;; To actually follow the link:
            ;; (send-url target)
            )
          hyperlink-clicked-style)))

;; Insert an image into the editor, the image is loaded from IMAGE-PATH and
;; will be in a paragraph by itself, and centered.
(define (insert-image editor image-path)
  (define snip (make-object image-snip% image-path))
  (send editor insert snip)
  (define paragraph (send editor last-paragraph))
  (send editor set-paragraph-alignment paragraph 'center))

;; Insert a single list item -- a number or bullet is perpended to ITEMS and
;; the list item is indented according to the list nesting level
(define (insert-list-item editor items style-list)
  (parameterize ([paragraph-indent (* 20 (list-nesting))])
    (define marker
      (if list-item
          (begin0
            (format "~a.    " list-item)
            (set! list-item (add1 list-item)))
          "•   "))
    (insert-markdown-items editor (cons marker items) style-list #t)))

;; Insert a markdown document in MD-TEXT -- MD-TEXT is parsed using
;; `parse-markdown` than the result is inserted into EDITOR
(define (insert-markdown editor md-text)
  (define md (parse-markdown md-text))
  (define initial-style-list (list base-style))
  (send editor begin-edit-sequence)
  (insert-markdown-items editor md initial-style-list)
  (send editor end-edit-sequence))


;;................................................... sample application ....

(define toplevel (new frame% [label "Markdown View"] [width 400] [height 150]))
(define canvas (new editor-canvas% [parent toplevel] [style '(no-hscroll)]))
(define text (new text%))

(send canvas set-editor text)
(send toplevel show #t)
(send text auto-wrap #t)
(send text set-padding 10 10 10 10)


(define tx #<<EOS
Hello **world**!
EOS
)
(insert-markdown text tx)
(send toplevel show #t)