From bc5e6269693ad400c17d5dcd21d60d5f03149ab9 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 17 Oct 2015 23:11:39 -0400 Subject: First commit! --- syntax-highlight/parsers.scm | 198 +++++++++++++++++++++++++++++++++++++++++++ syntax-highlight/scheme.scm | 102 ++++++++++++++++++++++ 2 files changed, 300 insertions(+) create mode 100644 syntax-highlight/parsers.scm create mode 100644 syntax-highlight/scheme.scm (limited to 'syntax-highlight') 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 +;;; +;;; 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 +;;; . + +;;; 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 +;;; +;;; 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 +;;; . + +;;; 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))")) -- cgit v1.2.3