From 54ecd4b9bb9cdf9ac7aab69336cd73d0bf66e569 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 27 Feb 2009 18:48:52 +0000 Subject: [PATCH] cleanup of syntax module svn: r13873 --- collects/xml/private/sig.ss | 9 +- collects/xml/private/syntax.ss | 229 +++++---------------------------- collects/xml/xml-sig.ss | 9 +- collects/xml/xml-unit.ss | 58 --------- 4 files changed, 43 insertions(+), 262 deletions(-) diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss index c37b259527..b317a64d93 100644 --- a/collects/xml/private/sig.ss +++ b/collects/xml/private/sig.ss @@ -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^) diff --git a/collects/xml/private/syntax.ss b/collects/xml/private/syntax.ss index 8e553b6c3e..5c601eb693 100644 --- a/collects/xml/private/syntax.ss +++ b/collects/xml/private/syntax.ss @@ -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)]))) diff --git a/collects/xml/xml-sig.ss b/collects/xml/xml-sig.ss index 1db8fea971..85a386f22f 100644 --- a/collects/xml/xml-sig.ss +++ b/collects/xml/xml-sig.ss @@ -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^) diff --git a/collects/xml/xml-unit.ss b/collects/xml/xml-unit.ss index 2ea7450497..1aff346605 100644 --- a/collects/xml/xml-unit.ss +++ b/collects/xml/xml-unit.ss @@ -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^)