suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add src argument to syntax:read-xml

Browse Source 
and pass it through into the syntax-source field of the result
This commit is contained in:
AlexKnauth 2018-06-17 03:03:21 -04:00 committed by Jay McCarthy
parent 0cd640811b
commit 3996f23879
1 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
racket/collects/xml/private/syntax.rkt
View File

@ -7,48 +7,57 @@
(provide/contract
; XXX these should both actually return syntax? that is also xexpr/c
[syntax:read-xml (() (input-port?) . ->* . syntax?)]
[syntax:read-xml/element (() (input-port?) . ->* . syntax?)])
[syntax:read-xml (() (input-port? #:src any/c) . ->* . syntax?)]
[syntax:read-xml/element (() (input-port? #:src any/c) . ->* . syntax?)])
(define (syntax:read-xml [in (current-input-port)])
;; the `src` argument is like the 1st argument to `read-syntax`:
;; it goes in the `syntax-source` field of the result
(define (syntax:read-xml [in (current-input-port)]
#:src [src (object-name in)])
(define the-xml (read-xml in))
(define the-xml-element (document-element the-xml))
(element->xexpr-syntax the-xml-element))
(element->xexpr-syntax src the-xml-element))
(define (syntax:read-xml/element [in (current-input-port)])
;; the `src` argument is like the 1st argument to `read-syntax`:
;; it goes in the `syntax-source` field of the result
(define (syntax:read-xml/element [in (current-input-port)]
#:src [src (object-name in)])
(define the-xml-element (read-xml/element in))
(element->xexpr-syntax the-xml-element))
(element->xexpr-syntax src the-xml-element))
(define (position from to)
(define (position src from to)
(let ([start-offset (location-offset from)])
(list #f (location-line from) (location-char from) start-offset
(list src
(location-line from) (location-char from) start-offset
(- (location-offset to) start-offset))))
(define (wrap s e)
(datum->syntax #f e (position (source-start s) (source-stop s))))
(define (wrap src s e)
(datum->syntax #f e (position src (source-start s) (source-stop s))))
(define (attribute->syntax a)
(wrap a (list (attribute-name a) (attribute-value a))))
(define ((attribute->syntax src) a)
(wrap src a (list (attribute-name a) (attribute-value a))))
(define (non-dropping-combine atts body)
(list* (map attribute->syntax atts) body))
(define (non-dropping-combine src atts body)
(list* (map (attribute->syntax src) atts) body))
(define (combine atts body)
(define (combine src atts body)
(if (xexpr-drop-empty-attributes)
(if (empty? atts)
body
(non-dropping-combine atts body))
(non-dropping-combine atts body)))
(non-dropping-combine src atts body))
(non-dropping-combine src atts body)))
(define (element->xexpr-syntax e)
(wrap e
(define (element->xexpr-syntax src e)
(wrap src
e
(list* (element-name e)
(combine (element-attributes e)
(map content->xexpr-syntax (element-content e))))))
(combine src
(element-attributes e)
(map (content->xexpr-syntax src) (element-content e))))))
(define (content->xexpr-syntax x)
(define ((content->xexpr-syntax src) x)
(cond
[(element? x) (element->xexpr-syntax x)]
[(pcdata? x) (wrap x (pcdata-string x))]
[(entity? x) (wrap x (entity-text x))]
[else (wrap x x)]))
[(element? x) (element->xexpr-syntax src x)]
[(pcdata? x) (wrap src x (pcdata-string x))]
[(entity? x) (wrap src x (entity-text x))]
[else (wrap src x x)]))