2 files changed, 300 insertions, 0 deletions
diff --git a/syntax-highlight/parsers.scm b/syntax-highlight/parsers.scm
new file mode 100644
index 0000000..2569b04
--- /dev/null
+++ b/syntax-highlight/parsers.scm
@@ -0,0 +1,198 @@
+;;; 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:
+;;
+;; Parsing utilities.
+;;
+;;; Code:
+
+(define-module (syntax-highlight parsers)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-41)
+  #:export (parse-fail
+            parse-bind
+            parse-return
+            parse-lift
+            parse-never
+            parse-map
+            parse-either
+            parse-both
+            parse-any
+            parse-each
+            parse-many
+            parse-string
+            parse-char-set
+            parse-whitespace
+            parse-delimited
+            tagged-parser))
+
+;;;
+;;; Parser combinators
+;;;
+
+(define (parse-fail stream)
+  "Return a failed parse value with STREAM as the remainder."
+  (values #f stream))
+
+(define (parse-bind proc parser)
+  (lambda (stream)
+    (let-values (((result stream) (parser stream)))
+      (if result
+          ((proc result) stream)
+          (parse-fail stream)))))
+
+(define (parse-return x)
+  "Return a parser that always yields X as the parse result."
+  (lambda (stream)
+    (values x stream)))
+
+(define (parse-lift proc)
+  "Return a procedure that wraps the result of PROC in a parser."
+  (lambda args
+    (parse-return (apply proc args))))
+
+(define (parse-never stream)
+  "Always fail to parse STREAM."
+  (parse-fail stream))
+
+(define (parse-map proc parser)
+  "Return a new parser that applies PROC to result of PARSER."
+  (parse-bind (parse-lift proc) parser))
+
+(define (parse-either first second)
+  "Create a parser that tries to parse with FIRST or, if that fails,
+parses SECOND."
+  (lambda (stream)
+    (let-values (((result stream) (first stream)))
+      (if result
+          (values result stream)
+          (second stream)))))
+
+(define (parse-both first second)
+  "Create a parser that returns a pair of the results of the parsers
+FIRST and SECOND if both are successful."
+  (lambda (stream)
+    (let-values (((result1 stream) (first stream)))
+      (if result1
+          (let-values (((result2 stream) (second stream)))
+            (if result2
+                (values (cons result1 result2) stream)
+                (parse-fail stream)))
+          (parse-fail stream)))))
+
+(define (parse-any . parsers)
+  "Create a parser that returns the result of the first successful
+parser in PARSERS.  This parser fails if no parser in PARSERS
+succeeds."
+  (fold-right parse-either parse-never parsers))
+
+(define (parse-each . parsers)
+  "Create a parser that builds a list of the results of PARSERS.  This
+parser fails without consuming any input if any parser in PARSERS
+fails."
+  (fold-right parse-both (parse-return '()) parsers))
+
+(define (parse-many parser)
+  "Create a parser that uses PARSER as many times as possible until it
+fails and return the results of each successful parse in a list.  This
+parser always succeeds."
+  (lambda (stream)
+    (let loop ((stream stream)
+               (results '()))
+      (let-values (((result remaining) (parser stream)))
+        (if result
+            (loop remaining (cons result results))
+            (values (reverse results)
+                    remaining))))))
+
+(define stream->string (compose list->string stream->list))
+
+(define (parse-string str)
+  "Create a parser that succeeds when the front of the stream contains
+the character sequence in STR."
+  (lambda (stream)
+    (let ((input (stream->string (stream-take (string-length str) stream))))
+      (if (string=? str input)
+          (values str (stream-drop (string-length str) stream))
+          (parse-fail stream)))))
+
+(define (parse-char-set char-set)
+  "Create a parser that returns a string containing a contiguous
+sequence of characters that belong to CHAR-SET."
+  (lambda (stream)
+    (let loop ((stream stream)
+               (result '()))
+      (define (stringify)
+        (if (null? result)
+            (parse-fail stream)
+            (values (list->string (reverse result))
+                    stream)))
+
+      (stream-match stream
+        (() (stringify))
+        ((head . rest)
+         (if (char-set-contains? char-set head)
+             (loop rest (cons head result))
+             (stringify)))))))
+
+(define parse-whitespace
+  (parse-char-set char-set:whitespace))
+
+(define* (parse-delimited str #:key (until str) (escape #\\))
+  "Create a parser that parses a delimited character sequence
+beginning with the string STR and ending with the string UNTIL.
+Within the sequence, ESCAPE is recognized as the escape character."
+  (let ((parse-str    (parse-string str))
+        (parse-until  (parse-string until)))
+
+    (define (stringify lst stream)
+      (values (list->string (reverse lst))
+              stream))
+
+    (define (parse-until-maybe stream)
+      (let-values (((result remaining) (parse-until stream)))
+        (and result remaining)))
+
+    (lambda (stream)
+      (let-values (((result remaining) (parse-str stream)))
+        (if result
+            (let loop ((stream remaining)
+                       (result (reverse (string->list str))))
+              (cond
+               ((stream-null? stream)
+                (stringify result stream))
+               ;; Escape character.
+               ((eqv? (stream-car stream) escape)
+                (stream-match (stream-cdr stream)
+                  (() (stringify result stream-null))
+                  ((head . rest)
+                   (loop rest (cons* head escape result)))))
+               ((parse-until-maybe stream) =>
+                (lambda (remaining)
+                  (stringify (append (string->list until) result) remaining)))
+               (else
+                (loop (stream-cdr stream) (cons (stream-car stream) result)))))
+            (parse-fail stream))))))
+
+(define (tagged-parser tag parser)
+  "Create a parser that wraps the result of PARSER in a two element
+list whose first element is TAG.."
+  (parse-map (cut list tag <>) parser))
diff --git a/syntax-highlight/scheme.scm b/syntax-highlight/scheme.scm
new file mode 100644
index 0000000..7839b1a
--- /dev/null
+++ b/syntax-highlight/scheme.scm
@@ -0,0 +1,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))"))