summaryrefslogtreecommitdiff
path: root/syntax-highlight
diff options
context:
space:
mode:
Diffstat (limited to 'syntax-highlight')
-rw-r--r--syntax-highlight/parsers.scm198
-rw-r--r--syntax-highlight/scheme.scm102
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))"))