cleanup of syntax module
svn: r13873
This commit is contained in:
Jay McCarthy
parent
7af4a81eff
commit
54ecd4b9bb
|
|
@ -82,8 +82,15 @@
|
|||
; XXX bad because of struct
|
||||
[eliminate-whitespace ((listof symbol?) (boolean? . -> . boolean?) . -> . (any/c . -> . any/c))])))
|
||||
|
||||
(define-signature xml-syntax^
|
||||
((contracted
|
||||
; 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?)])))
|
||||
|
||||
(provide xml-structs^
|
||||
writer^
|
||||
reader^
|
||||
xexpr^
|
||||
space^)
|
||||
space^
|
||||
xml-syntax^)
|
||||
|
|
|
|||
|
|
@ -1,212 +1,51 @@
|
|||
#lang scheme
|
||||
(require "sig.ss")
|
||||
|
||||
; to make error-raising functions named like structure mutators
|
||||
(define-syntax (struct! stx)
|
||||
(syntax-case stx ()
|
||||
[(struct-src name (field ...))
|
||||
(with-syntax ([struct:name (datum->syntax
|
||||
(syntax name)
|
||||
(string->symbol (string-append "struct:" (symbol->string (syntax->datum (syntax name))))))]
|
||||
[(setter-name ...)
|
||||
(let ([struct-name
|
||||
(symbol->string (syntax->datum (syntax name)))])
|
||||
(map (lambda (field-name)
|
||||
(datum->syntax
|
||||
field-name
|
||||
(string->symbol
|
||||
(string-append
|
||||
"set-"
|
||||
struct-name
|
||||
"-"
|
||||
(symbol->string (syntax->datum field-name))
|
||||
"!"))))
|
||||
(syntax->list (syntax (field ...)))))])
|
||||
(syntax
|
||||
(begin
|
||||
(define struct:name void)
|
||||
(define (setter-name s v)
|
||||
(error (quote setter-name) "cannot mutate XML syntax"))
|
||||
...)))]))
|
||||
(provide native-xml-syntax@)
|
||||
|
||||
(provide syntax-structs@)
|
||||
(define-unit syntax-structs@
|
||||
(import)
|
||||
(export xml-structs^)
|
||||
(define-unit native-xml-syntax@
|
||||
(import xml-structs^ reader^ xexpr^)
|
||||
(export xml-syntax^)
|
||||
|
||||
; The locations from the two sets of structures shouldn't mingle, so I'm
|
||||
; re-defining the location structure. Maybe this is not a good idea, but I
|
||||
; think it's okay.
|
||||
(define-struct location (line char offset))
|
||||
(define-struct source (start stop))
|
||||
(define (syntax:read-xml [in (current-input-port)])
|
||||
(define the-xml (read-xml in))
|
||||
(define the-xml-element (document-element the-xml))
|
||||
(element->xexpr-syntax the-xml-element))
|
||||
|
||||
; make-document : prolog element ? -> document
|
||||
(define (make-document p e ?) e)
|
||||
(define (syntax:read-xml/element [in (current-input-port)])
|
||||
(define the-xml-element (read-xml/element in))
|
||||
(element->xexpr-syntax the-xml-element))
|
||||
|
||||
; make-prolog : (listof Misc) Document-type (listof Misc) -> prolog
|
||||
(define (make-prolog misc dtd misc2) #f)
|
||||
|
||||
; make-element : src src sym (listof attribute) (listof content) -> element
|
||||
(define (make-element from to name attrs content)
|
||||
(wrap (list* name attrs content) from to))
|
||||
|
||||
; make-pcdata : src src str -> pcdata
|
||||
(define (make-pcdata from to x)
|
||||
(wrap x from to))
|
||||
|
||||
; make-cdata : src src str -> cdata
|
||||
(define (make-cdata from to x)
|
||||
(wrap x from to))
|
||||
|
||||
; make-entity : src src (U sym num) -> entity
|
||||
(define (make-entity from to entity)
|
||||
(wrap entity from to))
|
||||
|
||||
; make-comment : str -> comment
|
||||
; There is no syntax object representation for comments
|
||||
(define (make-comment x) #f)
|
||||
|
||||
; make-p-i : src src sym str -> p-i
|
||||
; There's not really a syntax object representation for p-i's either
|
||||
(define (make-p-i from to name val) #f)
|
||||
|
||||
; make-attribute : src src sym str -> attribute
|
||||
(define (make-attribute from to name val)
|
||||
(wrap (list name val) from to))
|
||||
|
||||
(define (make-document-type . x) #f)
|
||||
(define (make-external-dtd . x) #f)
|
||||
(define (make-external-dtd/public . x) #f)
|
||||
(define (make-external-dtd/system . x) #f)
|
||||
|
||||
; wrap : tst src src -> syntax
|
||||
(define (wrap x from to)
|
||||
(datum->syntax #f x (position from to)))
|
||||
|
||||
; position : src src -> (list #f nat nat nat nat)
|
||||
(define (position from to)
|
||||
(let ([start-offset (location-offset from)])
|
||||
(list #f (location-line from) (location-char from) start-offset
|
||||
(- (location-offset to) start-offset))))
|
||||
|
||||
; : syntax -> syntax
|
||||
(define (attribute-name a) (car (syntax->list a)))
|
||||
(define (attribute-value a) (cadr (syntax->list a)))
|
||||
(define (wrap s e)
|
||||
(datum->syntax #f e (position (source-start s) (source-stop s))))
|
||||
|
||||
; : syntax -> syntax
|
||||
(define (element-name e) (car (syntax->list e)))
|
||||
(define (element-attributes e) (cadr (syntax->list e)))
|
||||
(define (element-content e) (cddr (syntax->list e)))
|
||||
(define (attribute->syntax a)
|
||||
(wrap a (list (attribute-name a) (attribute-value a))))
|
||||
|
||||
(define (entity-text e) (syntax-e e))
|
||||
(define (non-dropping-combine atts body)
|
||||
(list* (map attribute->syntax atts) body))
|
||||
|
||||
(define (pcdata-string x) (syntax-e x))
|
||||
(define (cdata-string x) (syntax-e x))
|
||||
(define (combine atts body)
|
||||
(if (xexpr-drop-empty-attributes)
|
||||
(if (empty? atts)
|
||||
body
|
||||
(non-dropping-combine atts body))
|
||||
(non-dropping-combine atts body)))
|
||||
|
||||
(define (comment-text c)
|
||||
(error 'comment-text "expected a syntax representation of an XML comment, received ~e" c))
|
||||
; conflate documents with their root elements
|
||||
(define (document-element d) d)
|
||||
; more here - spoof document pieces better?
|
||||
(define (document-misc d) null)
|
||||
(define (document-prolog d) null)
|
||||
(define (element->xexpr-syntax e)
|
||||
(wrap e
|
||||
(list* (element-name e)
|
||||
(combine (element-attributes e)
|
||||
(map content->xexpr-syntax (element-content e))))))
|
||||
|
||||
(define (document-type-external dtd)
|
||||
(error 'document-type-external "expected a dtd, given ~e" dtd))
|
||||
|
||||
(define (document-type-inlined dtd)
|
||||
(error 'document-type-inlined "expected a dtd, given ~e" dtd))
|
||||
|
||||
(define (document-type-name dtd)
|
||||
(error 'document-type-name "expected a dtd, given ~e" dtd))
|
||||
|
||||
(define (external-dtd-system x)
|
||||
(error 'external-dtd-system "expected an external dtd, given ~e" x))
|
||||
|
||||
(define (external-dtd/public-public x)
|
||||
(error 'external-dtd/public-public "expected an external dtd, given ~e" x))
|
||||
|
||||
(define (p-i-instruction x)
|
||||
(error 'p-i-instruction "expected a p-i, given ~e" x))
|
||||
|
||||
(define (p-i-target-name x)
|
||||
(error 'p-i-target-name "expected a p-i, given ~e" x))
|
||||
|
||||
(define (prolog-dtd x)
|
||||
(error 'prolog-dtd "expected a prolog, given ~e" x))
|
||||
|
||||
(define (prolog-misc x)
|
||||
(error 'prolog-misc "expected a prolog, given ~e" x))
|
||||
|
||||
(define (prolog-misc2 x)
|
||||
(error 'prolog-misc2 "expected a prolog, given ~e" x))
|
||||
|
||||
; : tst -> bool
|
||||
(define (attribute? a)
|
||||
(and (syntax? a)
|
||||
(let ([x (syntax->datum a)])
|
||||
(and (pair? x) (symbol? (car x))
|
||||
(pair? (cdr x)) (string? (cadr x))
|
||||
(null? (cddr x))))))
|
||||
|
||||
|
||||
; : tst -> bool
|
||||
(define (comment? x) #f)
|
||||
|
||||
; : tst -> bool
|
||||
(define (content? x)
|
||||
(and (syntax? x)
|
||||
(or (string? (syntax->datum x))
|
||||
(element? x))))
|
||||
|
||||
; : tst -> bool
|
||||
(define (element? x)
|
||||
(and (syntax? x)
|
||||
(let ([e (syntax-e x)])
|
||||
(and (pair? e) (symbol? (car e))
|
||||
(pair? (cdr e)) (list? (cadr e))
|
||||
(andmap attribute? (cadr e))
|
||||
(list? (cddr e))
|
||||
(andmap content? (cddr e))))))
|
||||
|
||||
; : tst -> bool
|
||||
(define document? element?)
|
||||
|
||||
; : tst -> bool
|
||||
(define (document-type? x) #f)
|
||||
|
||||
; : tst -> bool
|
||||
(define (external-dtd/public? x) #f)
|
||||
(define (external-dtd/system? x) #f)
|
||||
(define (external-dtd? x) #f)
|
||||
|
||||
(define (prolog? x) #f)
|
||||
(define (p-i? x) #f)
|
||||
|
||||
; : tst -> bool
|
||||
(define (pcdata? x)
|
||||
(and (syntax? x) (string (syntax-e x))))
|
||||
(define (cdata? x)
|
||||
(and (syntax? x) (string (syntax-e x))))
|
||||
|
||||
; : tst -> bool
|
||||
(define (entity? x)
|
||||
(and (syntax? x) (let ([r (syntax-e x)]) (or (symbol? r) (number? r)))))
|
||||
|
||||
;(struct! location (line char offset))
|
||||
(struct! document (prolog element misc))
|
||||
(struct! comment (text))
|
||||
(struct! prolog (misc dtd misc2))
|
||||
(struct! document-type (name external inlined))
|
||||
(struct! external-dtd (system))
|
||||
(struct! external-dtd/public (public))
|
||||
(struct! external-dtd/system ())
|
||||
(struct! element (name attributes content))
|
||||
(struct! attribute (name value))
|
||||
(struct! p-i (target-name instruction))
|
||||
;(struct! source (start stop))
|
||||
(struct! pcdata (string))
|
||||
(struct! cdata (string))
|
||||
(struct! entity (text))
|
||||
|
||||
)
|
||||
(define (content->xexpr-syntax 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)])))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,6 @@
|
|||
#lang scheme
|
||||
(require "private/sig.ss")
|
||||
|
||||
(define-signature xml-syntax^
|
||||
((contracted
|
||||
; 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?)])))
|
||||
|
||||
(define-signature xml^
|
||||
((open xml-structs^)
|
||||
(open reader^)
|
||||
|
|
@ -15,5 +9,4 @@
|
|||
(open space^)
|
||||
(open xml-syntax^)))
|
||||
|
||||
(provide xml^
|
||||
xml-syntax^)
|
||||
(provide xml^)
|
||||
|
|
|
|||
|
|
@ -10,64 +10,6 @@
|
|||
|
||||
(provide xml@)
|
||||
|
||||
(define-unit reader->xml-syntax@
|
||||
(import reader^)
|
||||
(export xml-syntax^)
|
||||
(define syntax:read-xml read-xml)
|
||||
(define syntax:read-xml/element read-xml/element))
|
||||
|
||||
(define-compound-unit/infer xml-syntax@
|
||||
(import)
|
||||
(export xml-syntax^)
|
||||
(link syntax-structs@ reader@ reader->xml-syntax@))
|
||||
|
||||
(define-unit native-xml-syntax@
|
||||
(import xml-structs^ reader^ xexpr^)
|
||||
(export xml-syntax^)
|
||||
|
||||
(define (syntax:read-xml [in (current-input-port)])
|
||||
(define the-xml (read-xml in))
|
||||
(define the-xml-element (document-element the-xml))
|
||||
(element->xexpr-syntax the-xml-element))
|
||||
|
||||
(define (syntax:read-xml/element [in (current-input-port)])
|
||||
(define the-xml-element (read-xml/element in))
|
||||
(element->xexpr-syntax the-xml-element))
|
||||
|
||||
(define (position from to)
|
||||
(let ([start-offset (location-offset from)])
|
||||
(list #f (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 (attribute->syntax a)
|
||||
(wrap a (list (attribute-name a) (attribute-value a))))
|
||||
|
||||
(define (non-dropping-combine atts body)
|
||||
(list* (map attribute->syntax atts) body))
|
||||
|
||||
(define (combine atts body)
|
||||
(if (xexpr-drop-empty-attributes)
|
||||
(if (empty? atts)
|
||||
body
|
||||
(non-dropping-combine atts body))
|
||||
(non-dropping-combine atts body)))
|
||||
|
||||
(define (element->xexpr-syntax e)
|
||||
(wrap e
|
||||
(list* (element-name e)
|
||||
(combine (element-attributes e)
|
||||
(map content->xexpr-syntax (element-content e))))))
|
||||
|
||||
(define (content->xexpr-syntax 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)])))
|
||||
|
||||
(define-compound-unit/infer xml@
|
||||
(import)
|
||||
(export xml-structs^ reader^ xml-syntax^ writer^ xexpr^ space^)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user