summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2015-10-17 23:11:39 -0400
committerDavid Thompson <dthompson2@worcester.edu>2015-10-17 23:11:39 -0400
commitbc5e6269693ad400c17d5dcd21d60d5f03149ab9 (patch)
tree80d9e79e23193e9441227b16aa93ca284b75762a
First commit!
-rw-r--r--.gitignore10
-rw-r--r--COPYING165
-rw-r--r--Makefile.am49
-rw-r--r--README66
-rwxr-xr-xbootstrap3
-rw-r--r--configure.ac14
-rw-r--r--guix.scm59
-rw-r--r--pre-inst-env.in30
-rw-r--r--syntax-highlight.scm67
-rw-r--r--syntax-highlight/parsers.scm198
-rw-r--r--syntax-highlight/scheme.scm102
11 files changed, 763 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..9148070
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,10 @@
+*.go
+/Makefile
+/Makefile.in
+/aclocal.m4
+/autom4te.cache/
+/build-aux/
+/config.log
+/config.status
+/configure
+/pre-inst-env
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..cca7fc2
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..ac99bef
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,49 @@
+# 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/>.
+
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
+nobase_go_DATA = $(GOBJECTS)
+
+# Make sure source files are installed first, so that the mtime of
+# installed compiled files is greater than that of installed source
+# files. See
+# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
+# for details.
+guile_install_go_files = install-nobase_goDATA
+$(guile_install_go_files): install-nobase_modDATA
+
+CLEANFILES = $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
+SUFFIXES = .scm .go
+.scm.go:
+ $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<"
+
+moddir=$(prefix)/share/guile/site/2.0
+godir=$(libdir)/guile/2.0/ccache
+
+SOURCES = \
+ syntax-highlight/parsers.scm \
+ syntax-highlight/scheme.scm \
+ syntax-highlight.scm
+
+EXTRA_DIST += \
+ pre-inst-env.in \
+ README \
+ guix.scm
diff --git a/README b/README
new file mode 100644
index 0000000..f0a05df
--- /dev/null
+++ b/README
@@ -0,0 +1,66 @@
+-*- mode: org -*-
+
+Guile-syntax-highlight is a general-purpose syntax highlighting
+library for GNU Guile. It can parse code written in various
+programming languages into a simple s-expression that can be easily
+converted to HTML (via SXML) or any other format for rendering.
+
+* Example
+
+ #+BEGIN_SRC scheme
+ (use-modules (syntax-highlight)
+ (syntax-highlight scheme)
+ (sxml simple))
+
+ (define code
+ "(define (square x) \"Return the square of X.\" (* x x))")
+
+ ;; Get raw highlights list.
+ (define highlighted-code
+ (highlight scheme-highlighter code))
+
+ ;; Convert to SXML.
+ (define highlighted-sxml
+ (highlights->sxml highlighted-code))
+
+ ;; Write HTML to stdout.
+ (display (sxml->xml highlighted-sxml))
+ (newline)
+ #+END_SRC
+
+* Requirements
+
+ - GNU Guile >= 2.0.9
+
+* Building
+
+ Guile-syntax-highlight uses the familiar GNU build system and
+ requires GNU Make to build.
+
+** From tarball
+
+ After extracting the tarball, run:
+
+ #+BEGIN_SRC sh
+ ./configure
+ make
+ make install
+ #+END_SRC
+
+** From Git
+
+ In addition to GNU Make, building from Git requires GNU Automake
+ and Autoconf.
+
+ #+BEGIN_SRC sh
+ git clone git@dthompson.us:guile-syntax-highlight.git
+ cd guile-syntax-highlight
+ ./bootstrap
+ ./configure
+ make
+ make install
+ #+END_SRC
+
+* License
+
+ LGPLv3 or later. See =COPYING= for the full license text.
diff --git a/bootstrap b/bootstrap
new file mode 100755
index 0000000..872167c
--- /dev/null
+++ b/bootstrap
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+autoreconf -vif
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..d41b6d4
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,14 @@
+dnl -*- Autoconf -*-
+
+AC_INIT(Guile-syntax-highlight, 0.1)
+AC_CONFIG_SRCDIR(syntax-highlight)
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign])
+AM_SILENT_RULES([yes])
+
+AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+
+GUILE_PROGS([2.0.9])
+
+AC_OUTPUT
diff --git a/guix.scm b/guix.scm
new file mode 100644
index 0000000..090a8f7
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,59 @@
+;;; 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:
+;;
+;; GNU Guix development package. To build and install, run:
+;;
+;; guix package -f guix.scm
+;;
+;; To use as the basis for a development environment, run:
+;;
+;; guix environment -l guix.scm
+;;
+;;; Code:
+
+(use-modules (guix packages)
+ (guix licenses)
+ (guix git-download)
+ (guix build-system gnu)
+ (gnu packages)
+ (gnu packages autotools)
+ (gnu packages guile))
+
+(package
+ (name "guile-syntax-highlight")
+ (version "0.1")
+ (source #f)
+ (build-system gnu-build-system)
+ (arguments
+ '(#:phases
+ (modify-phases %standard-phases
+ (add-after 'unpack 'bootstrap
+ (lambda _ (zero? (system* "sh" "bootstrap")))))))
+ (native-inputs
+ `(("autoconf" ,autoconf)
+ ("automake" ,automake)))
+ (inputs
+ `(("guile" ,guile-2.0)))
+ (synopsis "General-purpose syntax highlighter for GNU Guile")
+ (description "Guile-syntax-highlight is a general-purpose syntax
+highlighting library for GNU Guile. It can parse code written in
+various programming languages into a simple s-expression that can be
+converted to HTML (via SXML) or any other format for rendering.")
+ (home-page "http://dthompson.us/software/guile-syntax-highlight")
+ (license lgpl3+))
diff --git a/pre-inst-env.in b/pre-inst-env.in
new file mode 100644
index 0000000..3d2a138
--- /dev/null
+++ b/pre-inst-env.in
@@ -0,0 +1,30 @@
+#!/bin/sh
+
+# 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/>.
+
+abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"
+abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
+
+GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
+export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
+
+PATH="$abs_top_builddir/scripts:$PATH"
+export PATH
+
+exec "$@"
diff --git a/syntax-highlight.scm b/syntax-highlight.scm
new file mode 100644
index 0000000..8aba7db
--- /dev/null
+++ b/syntax-highlight.scm
@@ -0,0 +1,67 @@
+;;; 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:
+;;
+;; General-purpose syntax highlighting framework.
+;;
+;;; Code:
+
+(define-module (syntax-highlight)
+ #: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 (highlight
+ highlights->sxml))
+
+(define (string->stream str)
+ "Convert the string STR into a stream of characters."
+ (stream-map (lambda (i)
+ (string-ref str i))
+ (stream-range 0 (string-length str))))
+
+(define* (highlight highlighter #:optional (stream (current-input-port)))
+ "Apply HIGHLIGHTER, a syntax highlighting procedure, to STREAM.
+STREAM may be an open port, string, or SRFI-41 character stream. If
+STREAM is not specified, characters are read from the current input
+port."
+ (let-values (((result stream)
+ (highlighter (cond
+ ((port? stream)
+ (port->stream stream))
+ ((string? stream)
+ (string->stream stream))
+ ((stream? stream)
+ stream)
+ (else
+ (error "Cannot convert to stream: " stream))))))
+ result))
+
+(define (highlights->sxml highlights)
+ "Convert HIGHLIGHTS, a list of syntax highlighting expressions, into
+a list of SXML 'span' nodes. Each 'span' node has a 'class' attribute
+corresponding to the highlighting tag name."
+ (define (tag->class tag)
+ (string-append "syntax-" (symbol->string tag)))
+
+ (map (match-lambda
+ ((? string? str) str)
+ ((tag text)
+ `(span (@ (class ,(tag->class tag))) ,text)))
+ highlights))
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))"))