Add forgotten files from markdown

markdown-mode/markdown-lexer.rkt

@@ -0,0 +1,91 @@
+#lang racket
+(require (for-syntax racket/base syntax/parse)
+         parser-tools/lex
+         (prefix-in : parser-tools/lex-sre))
+
+; The racket-lexer function returns 5 values:
+; - Either a string containing the matching text or the eof object.
+;   Block comments and specials currently return an empty string.
+;   This may change in the future to other string or non-string data.
+; - A symbol in '(error comment sexp-comment white-space constant string
+;                 no-color parenthesis hash-colon-keyword symbol eof other).
+; - A symbol in '(|(| |)| |[| |]| |{| |}|) or #f.
+; - A number representing the starting position of the match (or #f if eof).
+; - A number representing the ending position of the match (or #f if eof).
+
+(define-lex-abbrevs
+  [asterisk   "*"]
+  [hyphen     "-"]  
+  [underscore "_"]
+  [hash       "#"]  
+  [horizontal-rule  (:: (repetition 3 +inf.0 (:or hyphen asterisk underscore))
+                        (:* whitespace) #\newline)]
+  [header1          (:: "#" line)]
+  [header2          (:: "##" line)]
+  [header3          (:: "###" line)]
+  [header4          (:: "####" line)]
+  [header5          (:: "#####" line)]
+  [header6          (:: "######" line)]
+  [plain            (:: (:* (:~ (:or asterisk underscore))))]
+  [bold-start       asterisk]
+  [line             (:: (:* (:~ #\newline) #\newline))])
+
+(define-syntax (START stx) (syntax/loc stx (position-offset start-pos)))
+(define-syntax (END   stx) (syntax/loc stx (position-offset   end-pos)))
+(define-syntax (return stx)
+  (syntax-parse stx
+    [(_return token-expr)
+     (syntax/loc stx (values lexeme token-expr #f START END))]
+    [(_return lexeme-expr token-expr)
+     (syntax/loc stx (values lexeme-expr token-expr #f START END))]))
+
+(define markdown-line-lexer
+  (let ([state 0])
+    (lexer
+     [(eof) 'eof]
+     [(special)         (return ""     'no-color)]
+     [(special-comment) (return ""     'comment)]
+     [horizontal-rule   (return 'horizontal-rule)]
+     [header6           (return 'header6)]
+     [header5           (return 'header5)]
+     [header4           (return 'header4)]
+     [header3           (return 'header3)]
+     [header2           (return 'header2)]
+     [header1           (return 'header1)]
+     [plain             (return 'plain)]
+     [bold-start        
+      (return 'bold)]
+     [line              (return 'line)])))
+
+(define (lex-line str) (markdown-line-lexer (open-input-string str)))
+
+(define (test-token expr expected)
+  (define-values (lexeme token paren start end) (lex-line expr))
+  (unless (equal? token expected)
+    (error 'test-token (~a "expected " expected " got " token))))
+
+
+
+
+; Horizontal Rule
+;    three * - _ followed by whitespace
+(test-token "***\n"   'horizontal-rule)
+(test-token "***  \n" 'horizontal-rule)
+(test-token "---\n"   'horizontal-rule)
+(test-token "---  \n" 'horizontal-rule)
+(test-token "___\n"   'horizontal-rule)
+(test-token "___  \n" 'horizontal-rule)
+; Headers
+(test-token "# Header 1 (biggest)\n"       'header1)
+(test-token "## Header 2 \n"               'header2)
+(test-token "### Header 3 \n"              'header3)
+(test-token "#### Header 4 \n"             'header4)
+(test-token "##### Header 5 \n"            'header5)
+(test-token "###### Header 6 (smallest)\n" 'header6)
+; Plain Text
+(test-token "plain text (unformatted)" 'plain)
+; Bold
+(test-token "*bold*" 'bold)
+; Complicated
+(test-token "foo * bar" 'line)
+

markdown-mode/markdown-mode.rkt

@@ -0,0 +1,128 @@
+#lang racket/base
+(provide color-buffer
+         indent-for-tab
+         markdown-mode)
+
+(require racket/class racket/format racket/match racket/set
+         syntax-color/racket-lexer
+         "../buffer.rkt"
+         "../chars.rkt"
+         "../buffer-locals.rkt"
+         "../colors.rkt"
+         "../commands.rkt"
+         "../frame.rkt"
+         "../locals.rkt"
+         "../mark.rkt"
+         "../mode.rkt"
+         "../parameters.rkt"
+         "../point.rkt"
+         "../representation.rkt"
+         "../simple.rkt"
+         "../window.rkt"
+         "../text.rkt")
+
+;;;
+;;; MARKDOWN MODE
+;;;
+
+(define-interactive (markdown-mode [b (current-buffer)])
+  (define ns (current-namespace))
+  (localize ([current-buffer b])
+    ; add all commands from fundamental mode
+    (fundamental-mode b)
+    ; name
+    (set-major-mode! 'markdown)
+    (set-mode-name!  "Markdown")
+    ; keymap
+    (local! local-keymap
+            (λ (prefix key)
+              (match prefix
+                [(list)
+                 (match key
+                   ["M-left"    backward-sexp]
+                   ["M-right"   forward-sexp]
+                   ["M-S-right" forward-sexp/extend-region]
+                   ["M-S-left"  backward-sexp/extend-region]
+                   [_           #f])]
+                [_ #f])))
+    ; import markdown-mode into buffer-locals
+    (parameterize ([current-namespace (buffer-locals b)])
+      (namespace-attach-module ns 'racket/gui/base)
+      (namespace-attach-module ns "markdown-mode/markdown-mode.rkt")
+      (namespace-require          "markdown-mode/markdown-mode.rkt"))))
+
+; use markdown-mode automatically for all .md files
+(register-auto-mode "md" markdown-mode)
+
+
+
+
+;;;
+;;; INDENTATION
+;;;
+
+(define (indent-for-tab)
+  (insert "    "))
+
+
+;;;
+;;; SYNTAX COLORING
+;;;
+
+;;; Colors
+
+; See also "colors.rkt"
+(define brown orange)
+(define grey  (local text-color))
+(define black orange)
+
+; The lexer returns token and the type of token.
+; These colors are the standard colors used in DrRacket.
+
+; HASHEQ  color-ht : symbol -> color-or-false
+(define color-ht  
+  (hasheq 'error               red
+          'comment             orange  ; brown
+          'sexp-comment        base01  ; brown
+          'white-space         #f
+          'constant            green
+          'string              green
+          'no-color            #f
+          'parenthesis         base00  ; light grey
+          'hash-colon-keyword  blue
+          'symbol              blue
+          'eof                 #f
+          'other               cyan))
+
+; color-buffer : buffer integer integer -> void
+(define (color-buffer [b (current-buffer)] [from 0] [to #f])
+  ; (log-warning (~a (list 'color-buffer (buffer-name b) from to)))
+  ; (displayln (list "racket-mode.rkt" 'color-buffer 'from from 'to to))
+  ; (displayln (list "racket-mode: color-buffer"))
+  ;; set optional arguments
+  (localize ([current-buffer b])
+    (unless to (set! to (buffer-length b)))
+    ;; turn buffer into input port
+    (define in (open-input-buffer b))
+    ;; backtrack to a known place outside strings, comments etc.
+    (define safe-pos
+      (with-saved-point
+        (goto-char from)
+        (backward-to-open-parenthesis-on-beginning-of-line)
+        (point)))
+    (file-position in safe-pos)
+    ;; call the lexer in a loop and use overlays to record the colors
+    (let loop ()
+      (define-values (token style paren start end) (racket-lexer in))
+      (cond
+        [(eof-object? token) (void)]
+        [else                ; (writeln (list token style (~a paren) (list start end)))
+         (define color (hash-ref color-ht style grey))
+         (overlay-set (- start 1) (- end 1) 'color color b)
+         (when (< end to)
+           (loop))]))))
+
+;;;
+;;; MOVEMENT
+;;;
+