diff options
author | David Thompson <dthompson2@worcester.edu> | 2015-10-19 09:12:50 -0400 |
---|---|---|
committer | David Thompson <dthompson2@worcester.edu> | 2015-10-19 09:12:50 -0400 |
commit | 06e4362f601fcdacadc5f158b40b079d34688b21 (patch) | |
tree | ada26df115ddcc8a6b88f0974b4cb0f166db8c7c /syntax-highlight/xml.scm | |
parent | 668892ebbcdcfa92a57a62e737f567a23d707aa0 (diff) |
Add XML highlighter.
* syntax-highlight/xml.scm: New file
* Makefile.am (SOURCES): Add it.
* README ("Supported Languages"): Add "XML."
Diffstat (limited to 'syntax-highlight/xml.scm')
-rw-r--r-- | syntax-highlight/xml.scm | 111 |
1 files changed, 111 insertions, 0 deletions
diff --git a/syntax-highlight/xml.scm b/syntax-highlight/xml.scm new file mode 100644 index 0000000..371f36f --- /dev/null +++ b/syntax-highlight/xml.scm @@ -0,0 +1,111 @@ +;;; 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 xml) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-41) + #:use-module (syntax-highlight parsers) + #:export (xml-highlighter)) + +(define (flatten+compact highlights) + (define tagged? + (match-lambda + (((? symbol?) _) #t) + (_ #f))) + + (let loop ((highlights highlights) + (result '())) + (match highlights + (() (reverse result)) + (("" . tail) + (loop tail result)) + (((or (? string? head) (? tagged? head)) . tail) + (loop tail (cons head result))) + ((head . tail) + (loop tail (append (reverse (flatten+compact head)) result)))))) + +(define parse-comment + (tagged-parser 'comment (parse-delimited "<!--" #:until "-->"))) + +(define parse-xml-symbol + (parse-char-set + (char-set-union char-set:letter+digit + (char-set #\. #\- #\_ #\:)))) + +(define parse-element-name + (tagged-parser 'element parse-xml-symbol)) + +(define parse-whitespace-maybe + (parse-maybe parse-whitespace)) + +(define parse-attribute + (parse-each (tagged-parser 'attribute parse-xml-symbol) + parse-whitespace-maybe + (parse-string "=") + parse-whitespace-maybe + (tagged-parser 'string (parse-delimited "\"")))) + +(define parse-open-tag + (parse-each (tagged-parser 'open (parse-any (parse-string "<?") + (parse-string "<"))) + parse-element-name + (parse-many + (parse-any (parse-each + parse-whitespace + parse-attribute) + parse-whitespace)) + (tagged-parser 'close (parse-any (parse-string ">") + (parse-string "/>") + (parse-string "?>"))))) + +(define parse-close-tag + (parse-each (tagged-parser 'open (parse-string "</")) + parse-element-name + (tagged-parser 'close (parse-string ">")))) + +(define char-set:not-whitespace + (char-set-complement char-set:whitespace)) + +(define parse-tag + (parse-each (parse-string "<") + (parse-char-set + (char-set-delete char-set:not-whitespace #\>)) + (parse-string ">"))) + +(define parse-entity + (tagged-parser 'entity (parse-delimited "&" #:until ";"))) + +(define parse-text + (parse-char-set + (char-set-difference char-set:full (char-set #\<)))) + +(define xml-highlighter + (parse-map flatten+compact + (parse-many + (parse-any parse-comment + parse-open-tag + parse-close-tag + parse-entity + parse-text)))) |