summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--pict.scm41
-rw-r--r--pict/sxml.scm180
2 files changed, 215 insertions, 6 deletions
diff --git a/pict.scm b/pict.scm
index a9ec612..c755aed 100644
--- a/pict.scm
+++ b/pict.scm
@@ -1,6 +1,6 @@
;;; pict.scm --- A simple picture language for Guile
-;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -18,7 +18,8 @@
(define-module (pict)
- #:use-module (sxml simple)
+ #:use-module (pict sxml)
+ #:use-module ((sxml simple) #:hide (xml->sxml))
#:use-module (sxml transform)
#:use-module (sxml fold)
#:use-module ((sxml xpath) #:hide (filter))
@@ -34,6 +35,8 @@
pict-height
pict-rotation
+ pict-from-file
+
;; modifiers
fill
colorize
@@ -145,6 +148,22 @@ list VALS."
'(0 . ())
(cons 0 vals))))
+(define (pict-from-file file-name)
+ "Attempt to read FILE-NAME, convert its contents to SXML and wrap it
+in a <PICT> record. If this fails return #F."
+ (catch 'parser-error
+ (lambda ()
+ (make-pict
+ (match (call-with-input-file file-name xml->sxml)
+ (('*TOP* ('*PI* . rest) svg) svg)
+ (('*TOP* svg) svg))))
+ (lambda _
+ (format (current-error-port)
+ "Failed to parse picture from file `~a'.~%\
+Is this really an SVG file?~%"
+ file-name)
+ #f)))
+
;;; SXML utilities
@@ -689,12 +708,22 @@ of the SVG of PICT or #F."
(car m)))))
(define (pict-height pict)
- "Return the height of PICT."
- (pict-attr 'height pict))
+ "Return the numeric height of PICT."
+ (match (pict-attr 'height pict)
+ ((? string? s)
+ ;; Take value up to unit and convert to number
+ (let ((index (string-skip s char-set:digit)))
+ (string->number (substring s 0 index))))
+ ((? number? n) n)))
(define (pict-width pict)
- "Return the width of PICT."
- (pict-attr 'width pict))
+ "Return the numeric width of PICT."
+ (match (pict-attr 'width pict)
+ ((? string? s)
+ ;; Take value up to unit and convert to number
+ (let ((index (string-skip s char-set:digit)))
+ (string->number (substring s 0 index))))
+ ((? number? n) n)))
(define (pict-rotation pict)
"Return the rotation of PICT."
diff --git a/pict/sxml.scm b/pict/sxml.scm
new file mode 100644
index 0000000..99628bd
--- /dev/null
+++ b/pict/sxml.scm
@@ -0,0 +1,180 @@
+;;; pict.scm --- A simple picture language for Guile
+
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This library 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.
+;;;
+;;; This library 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 this library. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This is an adaptation of Guile's xml->sxml from (sxml simple), as
+;;; released in version 2.2.4. The difference is in the handling of
+;;; namespaces, which is important for round trips XML->SXML->XML
+;;; again. For more information see Guile bug 20339
+;;; <https://bugs.gnu.org/20339>
+
+(define-module (pict sxml)
+ #:use-module (sxml simple)
+ #:use-module (sxml ssax input-parse)
+ #:use-module (sxml ssax)
+ #:use-module (sxml transform)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (xml->sxml))
+
+(define* (xml->sxml #:optional (string-or-port (current-input-port)) #:key
+ (namespaces '())
+ (declare-namespaces? #t)
+ (trim-whitespace? #f)
+ (entities '())
+ (default-entity-handler #f)
+ (doctype-handler #f))
+ "Use SSAX to parse an XML document into SXML. Takes one optional
+argument, @var{string-or-port}, which defaults to the current input
+port."
+ ;; NAMESPACES: alist of PREFIX -> URI. Specifies the symbol prefix
+ ;; that the user wants on elements of a given namespace in the
+ ;; resulting SXML, regardless of the abbreviated namespaces defined in
+ ;; the document by xmlns attributes. If DECLARE-NAMESPACES? is true,
+ ;; these namespaces are treated as if they were declared in the DTD.
+
+ ;; ENTITIES: alist of SYMBOL -> STRING.
+
+ ;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
+ ;; A DOC-PREFIX of #f indicates that it comes from the user.
+ ;; Otherwise, prefixes are symbols.
+ (define (munge-namespaces namespaces)
+ (map (lambda (el)
+ (match el
+ ((prefix . uri-string)
+ (cons* (and declare-namespaces? prefix)
+ prefix
+ (ssax:uri-string->symbol uri-string)))))
+ namespaces))
+
+ (define (user-namespaces)
+ (munge-namespaces namespaces))
+
+ (define (user-entities)
+ (if (and default-entity-handler
+ (not (assq '*DEFAULT* entities)))
+ (acons '*DEFAULT* default-entity-handler entities)
+ entities))
+
+ (define (name->sxml name namespaces)
+ (match name
+ ((prefix . local-part)
+ (let ((abbrev (and=> (find (match-lambda
+ ((abbrev uri . rest)
+ (and (eq? uri prefix) abbrev)))
+ namespaces)
+ first)))
+ (symbol-append abbrev (string->symbol ":") local-part)))
+ (_ name)))
+
+ (define (doctype-continuation seed)
+ (lambda* (#:key (entities '()) (namespaces '()))
+ (values #f
+ (append entities (user-entities))
+ (append (munge-namespaces namespaces) (user-namespaces))
+ seed)))
+
+ ;; The SEED in this parser is the SXML: initialized to '() at each new
+ ;; level by the fdown handlers; built in reverse by the fhere parsers;
+ ;; and reverse-collected by the fup handlers.
+ (define parser
+ (ssax:make-parser
+ NEW-LEVEL-SEED ; fdown
+ (lambda (elem-gi attributes namespaces expected-content seed)
+ '())
+
+ FINISH-ELEMENT ; fup
+ (lambda (elem-gi attributes namespaces parent-seed seed)
+ (let ((seed (if trim-whitespace?
+ ((@@ (sxml simple) ssax:reverse-collect-str-drop-ws) seed)
+ ((@@ (sxml simple) ssax:reverse-collect-str) seed)))
+ (attrs (append
+ ;; Namespace declarations
+ (filter-map (match-lambda
+ (('*DEFAULT* . _) #f)
+ ((abbrev uri . _)
+ (list (symbol-append 'xmlns: abbrev)
+ (symbol->string uri))))
+ namespaces)
+ (attlist-fold
+ (lambda (attr accum)
+ (cons (list (name->sxml (car attr) namespaces)
+ (cdr attr))
+ accum))
+ '() attributes))))
+ (acons (name->sxml elem-gi namespaces)
+ (if (null? attrs)
+ seed
+ (cons (cons '@ attrs) seed))
+ parent-seed)))
+
+ CHAR-DATA-HANDLER ; fhere
+ (lambda (string1 string2 seed)
+ (if (string-null? string2)
+ (cons string1 seed)
+ (cons* string2 string1 seed)))
+
+ DOCTYPE
+ ;; -> ELEMS ENTITIES NAMESPACES SEED
+ ;;
+ ;; ELEMS is for validation and currently unused.
+ ;;
+ ;; ENTITIES is an alist of parsed entities (symbol -> string).
+ ;;
+ ;; NAMESPACES is as above.
+ ;;
+ ;; SEED builds up the content.
+ (lambda (port docname systemid internal-subset? seed)
+ (call-with-values
+ (lambda ()
+ (cond
+ (doctype-handler
+ (doctype-handler docname systemid
+ (and internal-subset?
+ ((@@ (sxml simple) read-internal-doctype-as-string) port))))
+ (else
+ (when internal-subset?
+ (ssax:skip-internal-dtd port))
+ (values))))
+ (doctype-continuation seed)))
+
+ UNDECL-ROOT
+ ;; This is like the DOCTYPE handler, but for documents that do not
+ ;; have a <!DOCTYPE!> entry.
+ (lambda (elem-gi seed)
+ (call-with-values
+ (lambda ()
+ (if doctype-handler
+ (doctype-handler #f #f #f)
+ (values)))
+ (doctype-continuation seed)))
+
+ PI
+ ((*DEFAULT*
+ . (lambda (port pi-tag seed)
+ (cons
+ (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+ seed))))))
+
+ (let* ((port (if (string? string-or-port)
+ (open-input-string string-or-port)
+ string-or-port))
+ (elements (reverse (parser port '()))))
+ `(*TOP* ,@elements)))