summaryrefslogtreecommitdiff
path: root/syntax-highlight/scheme.scm
blob: 7839b1a28333a01ba5aa05e4cad0a8b45a54316b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
;;; guile-syntax-highlight --- General-purpose syntax highlighter
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; Guile-syntax-highlight is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; Guile-syntax-highlight is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with guile-syntax-highlight.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Syntax highlighting for Scheme.
;;
;;; Code:

(define-module (syntax-highlight scheme)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-41)
  #:use-module (syntax-highlight parsers)
  #:export (scheme-highlighter))

(define char-set:lisp-delimiters
  (char-set-union char-set:whitespace
                  (char-set #\( #\) #\[ #\] #\{ #\})))

(define (lisp-delimiter? char)
  (char-set-contains? char-set:lisp-delimiters char))

(define (parse-specials special-words)
  "Create a parser for SPECIAL-WORDS, a list of important terms for a
language."
  (define (special word)
    (let ((parser (tagged-parser 'special (parse-string word))))
      (lambda (stream)
        (let-values (((result rest-of-stream) (parser stream)))
          (if (and result (lisp-delimiter? (stream-car stream)))
              (values result rest-of-stream)
              (parse-fail stream))))))

  (fold parse-either parse-never (map special special-words)))

(define (parse-openers openers)
  (define (open opener)
    (tagged-parser 'open (parse-string opener)))

  (fold parse-either parse-never (map open openers)))

(define (parse-closers closers)
  (define (close closer)
    (tagged-parser 'close (parse-string closer)))

  (fold parse-either parse-never (map close closers)))

(define parse-symbol
  (tagged-parser 'symbol
                 (parse-char-set
                  (char-set-complement char-set:lisp-delimiters))))

(define parse-keyword
  (tagged-parser 'keyword
                 (parse-map string-concatenate
                            (parse-each (parse-string "#:")
                                        (parse-char-set
                                         (char-set-complement
                                          char-set:lisp-delimiters))))))

(define parse-string-literal
  (tagged-parser 'string (parse-delimited "\"")))

(define parse-comment
  (tagged-parser 'comment (parse-delimited ";" #:until "\n")))

(define parse-quoted-symbol
  (tagged-parser 'symbol (parse-delimited "#{" #:until "}#")))

(define scheme-highlighter
  (parse-many
   (parse-any parse-whitespace
              (parse-openers '("(" "[" "{"))
              (parse-closers '(")" "]" "}"))
              (parse-specials '("define" "lambda"))
              parse-string-literal
              parse-comment
              parse-keyword
              parse-quoted-symbol
              parse-symbol)))

;; (scheme-highlighter
;;  (string->stream
;;   "(define* (foo bar #:key (baz 'quux))
;;   \"This is a docstring!\"
;;   #u8(1 2 3)
;;   (1+ bar))"))