@ -1,12 +1,90 @@
#lang typed/racket/base
#lang racket/base
( require ( for-syntax typed/racket/base ) typed/sugar/define )
( require sugar/define racket/string racket/list racket/match xml )
( require racket/match racket/string racket/list racket/bool " core-predicates.rkt " )
( provide cdata? cdata valid-char? xexpr->string xexpr? ) ; from xml
( provide ( all-defined-out ) ( all-from-out " core-predicates.rkt " ) )
;; Section 2.2 of XML 1.1
( define/typed ( validate-txexpr-attrs x #:context [ txexpr-context #f ] )
;; (XML 1.0 is slightly different and more restrictive)
( Txexpr-Attrs [ #:context Any ] -> Txexpr-Attrs )
;; make private version of my-valid-char to get consistent results with Racket 6.0
( define/typed ( make-reason )
( define ( my-valid-char? i )
( -> String )
( and ( exact-nonnegative-integer? i )
( or ( <= #x1 i #xD7FF )
( <= #xE000 i #xFFFD )
( <= #x10000 i #x10FFFF ) ) ) )
( define ( my-xexpr? x )
( or ( txexpr? x ) ( xexpr? x ) ( my-valid-char? x ) ) )
( define+provide+safe ( txexpr-short? x )
predicate/c
( match x
[ ( list ( ? symbol? name ) ( ? my-xexpr? ) ... ) #t ]
[ else #f ] ) )
( define+provide+safe ( txexpr? x )
predicate/c
( or ( txexpr-short? x )
( match x
[ ( list ( ? symbol? ) ( list ( list ( ? symbol? ) ( ? string? ) ) ... ) ( ? my-xexpr? ) ... ) #t ]
[ else #f ] ) ) )
( define+provide+safe ( txexpr-tag? x )
predicate/c
( symbol? x ) )
( define+provide+safe ( txexpr-tags? x )
predicate/c
( and ( list? x ) ( andmap txexpr-tag? x ) ) )
( define+provide+safe ( txexpr-attr? x )
predicate/c
( match x
[ ( list ( ? symbol? ) ( ? string? ) ) #t ]
[ else #f ] ) )
( define+provide+safe ( txexpr-attrs? x )
predicate/c
( and ( list? x ) ( andmap txexpr-attr? x ) ) )
( define+provide+safe ( txexpr-element? x )
predicate/c
( my-xexpr? x ) )
( define+provide+safe ( txexpr-elements? x )
predicate/c
( and ( list? x ) ( andmap txexpr-element? x ) ) )
( define+provide+safe ( txexpr-attr-key? x )
predicate/c
( symbol? x ) )
( define+provide+safe ( can-be-txexpr-attr-key? x )
predicate/c
( or ( symbol? x ) ( string? x ) ) )
( define+provide+safe ( txexpr-attr-value? x )
predicate/c
( string? x ) )
( define+provide+safe ( txexpr-attr-values? x )
predicate/c
( and ( list? x ) ( andmap txexpr-attr-value? x ) ) )
( define+provide+safe ( can-be-txexpr-attr-value? x )
predicate/c
( or ( symbol? x ) ( string? x ) ) )
( define+provide+safe ( can-be-txexpr-attrs? x )
predicate/c
( ormap ( λ ( test ) ( test x ) ) ( list txexpr-attr? txexpr-attrs? can-be-txexpr-attr-key? can-be-txexpr-attr-value? ) ) )
( define+provide+safe ( list-of-can-be-txexpr-attrs? xs )
predicate/c
( and ( list? xs ) ( andmap can-be-txexpr-attrs? xs ) ) )
( define ( validate-txexpr-attrs x #:context [ txexpr-context #f ] )
( define ( make-reason )
( if ( not ( list? x ) )
( if ( not ( list? x ) )
( format " because ~v is not a list " x )
( format " because ~v is not a list " x )
( let ( [ bad-attrs ( filter ( λ ( i ) ( not ( txexpr-attr? i ) ) ) x ) ] )
( let ( [ bad-attrs ( filter ( λ ( i ) ( not ( txexpr-attr? i ) ) ) x ) ] )
@ -20,8 +98,7 @@
( format " ~v is not a valid list of attributes ~a " x ( make-reason ) ) ) ) ] ) )
( format " ~v is not a valid list of attributes ~a " x ( make-reason ) ) ) ) ] ) )
( define/typed ( validate-txexpr-element x #:context [ txexpr-context #f ] )
( define ( validate-txexpr-element x #:context [ txexpr-context #f ] )
( Txexpr-Element [ #:context Any ] -> Txexpr-Element )
( cond
( cond
[ ( or ( string? x ) ( txexpr? x ) ( symbol? x )
[ ( or ( string? x ) ( txexpr? x ) ( symbol? x )
( valid-char? x ) ( cdata? x ) ) x ]
( valid-char? x ) ( cdata? x ) ) x ]
@ -32,22 +109,20 @@
;; is it a named x-expression?
;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
( define /typed ( validate-txexpr x )
( define +provide+safe ( validate-txexpr x )
( Any -> ( Option Txexpr ) )
( any/c . -> . txexpr? )
( define-syntax-rule ( validate-txexpr-attrs-with-context e ) ( validate-txexpr-attrs e #:context x ) )
( define-syntax-rule ( validate-txexpr-attrs-with-context e ) ( validate-txexpr-attrs e #:context x ) )
( define-syntax-rule ( validate-txexpr-element-with-context e ) ( validate-txexpr-element e #:context x ) )
( define-syntax-rule ( validate-txexpr-element-with-context e ) ( validate-txexpr-element e #:context x ) )
( cond
( cond
[ ( txexpr-short? x ) x ]
[ ( txexpr-short? x ) x ]
[ ( txexpr? x ) ( and
[ ( txexpr? x ) ( and
( validate-txexpr-attrs-with-context ( get-attrs x ) )
( validate-txexpr-attrs-with-context ( get-attrs x ) )
( andmap ( λ: ( [ e : Txexpr-Element ] ) ( validate-txexpr-element-with-context e ) ) ( get-elements x ) ) x ) ]
( andmap ( λ ( e ) ( validate-txexpr-element-with-context e ) ) ( get-elements x ) ) x ) ]
[ else ( error ' validate-txexpr ( format " ~v is not a list starting with a symbol " x ) ) ] ) )
[ else ( error ' validate-txexpr ( format " ~v is not a list starting with a symbol " x ) ) ] ) )
( define/typed ( make-txexpr tag [ attrs null ] [ elements null ] )
( define+provide+safe ( make-txexpr tag [ attrs null ] [ elements null ] )
( case-> ( Symbol -> Txexpr )
( ( symbol? ) ( txexpr-attrs? txexpr-elements? ) . ->* . txexpr? )
( Symbol Txexpr-Attrs -> Txexpr )
( Symbol Txexpr-Attrs ( Listof Txexpr-Element ) -> Txexpr ) )
( define result ( cons tag ( append ( if ( empty? attrs ) empty ( list attrs ) ) elements ) ) )
( define result ( cons tag ( append ( if ( empty? attrs ) empty ( list attrs ) ) elements ) ) )
( if ( txexpr? result )
( if ( txexpr? result )
result
result
@ -62,66 +137,63 @@
[ else " " ] ) ) ) )
[ else " " ] ) ) ) )
( define /typed ( txexpr->values x )
( define +provide+safe ( txexpr->values x )
( Txexpr -> ( values Txexpr-Tag Txexpr-Attrs Txexpr-Elements ) )
( txexpr? . -> . ( values symbol? txexpr-attrs? txexpr-elements? ) )
( if ( txexpr-short? x )
( if ( txexpr-short? x )
( values ( car x ) ' ( ) ( cdr x ) )
( values ( car x ) ' ( ) ( cdr x ) )
( values ( car x ) ( cadr x ) ( cddr x ) ) ) )
( values ( car x ) ( cadr x ) ( cddr x ) ) ) )
( define /typed ( txexpr->list x )
( define +provide+safe ( txexpr->list x )
( Txexpr -> ( List Txexpr-Tag Txexpr-Attrs Txexpr-Elements ) )
( txexpr? . -> . list? )
( define-values ( tag attrs content ) ( txexpr->values x ) )
( define-values ( tag attrs content ) ( txexpr->values x ) )
( list tag attrs content ) )
( list tag attrs content ) )
;; convenience functions to retrieve only one part of txexpr
;; convenience functions to retrieve only one part of txexpr
( define /typed ( get-tag x )
( define +provide+safe ( get-tag x )
( Txexpr -> Txexpr-Tag )
( txexpr? . -> . txexpr-tag? )
( car x ) )
( car x ) )
( define /typed ( get-attrs x )
( define +provide+safe ( get-attrs x )
( Txexpr -> Txexpr-Attrs )
( txexpr? . -> . txexpr-attrs? )
( define-values ( tag attrs content ) ( txexpr->values x ) )
( define-values ( tag attrs content ) ( txexpr->values x ) )
attrs )
attrs )
( define /typed ( get-elements x )
( define +provide+safe ( get-elements x )
( Txexpr -> Txexpr-Elements )
( txexpr? . -> . txexpr-elements? )
( define-values ( tag attrs elements ) ( txexpr->values x ) )
( define-values ( tag attrs elements ) ( txexpr->values x ) )
elements )
elements )
;; helpers. we are getting a string or symbol
;; helpers. we are getting a string or symbol
( define /typed ( ->txexpr-attr-key x )
( define +provide+safe ( ->txexpr-attr-key x )
( Can-Be-Txexpr-Attr-Key -> Txexpr-Attr-Key )
( can-be-txexpr-attr-key? . -> . txexpr-attr-key? )
( if ( string? x ) ( string->symbol x ) x ) )
( if ( string? x ) ( string->symbol x ) x ) )
( define /typed ( ->txexpr-attr-value x )
( define +provide+safe ( ->txexpr-attr-value x )
( Can-Be-Txexpr-Attr-Value -> Txexpr-Attr-Value )
( can-be-txexpr-attr-value? . -> . txexpr-attr-value? )
( ->string x ) )
( ->string x ) )
( define/typed ( ->string x )
( define ( ->string x )
( ( U Symbol String ) -> String )
( if ( symbol? x ) ( symbol->string x ) x ) )
( if ( symbol? x ) ( symbol->string x ) x ) )
( define /typed ( attrs->hash . items-in )
( define +provide+safe ( attrs->hash . items-in )
( Can-Be-Txexpr-Attr * -> Txexpr-Attr-Hash )
( ( ) #:rest ( listof can-be-txexpr-attrs? ) . ->* . hash? )
;; can be liberal with input because they're all just nested key/value pairs
;; can be liberal with input because they're all just nested key/value pairs
;; but still need this function to make sure that 'foo and "foo" are treated as the same hash key
;; but still need this function to make sure that 'foo and "foo" are treated as the same hash key
( define items ( reverse
( define items ( reverse
( for/fold: ( [ items : ( Listof ( U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value ) ) null ] )
( for/fold ( [ items null ] ) ( [ i ( in-list items-in ) ] )
( [ i ( in-list items-in ) ] )
( cond
( cond
[ ( txexpr-attr? i ) ( append ( reverse i ) items ) ]
[ ( txexpr-attr? i ) ( append ( reverse i ) items ) ]
[ ( txexpr-attrs? i ) ( append ( append* ( map ( λ: ( [ a : Txexpr-Attr ] ) ( reverse a ) ) i ) ) items ) ]
[ ( txexpr-attrs? i ) ( append ( append* ( map ( λ ( a ) ( reverse a ) ) i ) ) items ) ]
[ else ( cons i items ) ] ) ) ) )
[ else ( cons i items ) ] ) ) ) )
( define/typed ( make-key-value-list items )
( define ( make-key-value-list items )
( ( Listof ( U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value ) ) -> ( Listof ( Pairof Txexpr-Attr-Key Txexpr-Attr-Value ) ) )
( if ( < ( length items ) 2 )
( if ( < ( length items ) 2 )
null
null
( let ( [ key ( ->txexpr-attr-key ( car items ) ) ]
( let ( [ key ( ->txexpr-attr-key ( car items ) ) ]
@ -131,19 +203,19 @@
( make-immutable-hash ( make-key-value-list items ) ) )
( make-immutable-hash ( make-key-value-list items ) ) )
( define /typed ( hash->attrs attr-hash )
( define +provide+safe ( hash->attrs attr-hash )
( Txexpr-Attr-Hash -> Txexpr-Attrs )
( hash? . -> . txexpr-attrs? )
( map ( λ: ( [ k : Txexpr-Attr-Key ] ) ( list k ( hash-ref attr-hash k ) ) ) ( hash-keys attr-hash ) ) )
( map ( λ ( k ) ( list k ( hash-ref attr-hash k ) ) ) ( hash-keys attr-hash ) ) )
( define /typed ( attrs-have-key? x key )
( define +provide+safe ( attrs-have-key? x key )
( ( U Txexpr-Attrs Txexpr ) Can-Be-Txexpr-Attr-Key -> Boolean )
( ( or/c txexpr-attrs? txexpr? ) can-be-txexpr-attr-key? . -> . boolean? )
( define attrs ( if ( txexpr-attrs? x ) x ( get-attrs x ) ) )
( define attrs ( if ( txexpr-attrs? x ) x ( get-attrs x ) ) )
( hash-has-key? ( attrs->hash attrs ) ( ->txexpr-attr-key key ) ) )
( hash-has-key? ( attrs->hash attrs ) ( ->txexpr-attr-key key ) ) )
( define /typed ( attrs-equal? x1 x2 )
( define +provide+safe ( attrs-equal? x1 x2 )
( ( U Txexpr-Attrs Txexpr ) ( U Txexpr-Attrs Txexpr ) -> Boolean )
( ( or/c txexpr-attrs? txexpr? ) ( or/c txexpr-attrs? txexpr? ) . -> . boolean? )
( define attrs-tx1 ( attrs->hash ( if ( txexpr-attrs? x1 ) x1 ( get-attrs x1 ) ) ) )
( define attrs-tx1 ( attrs->hash ( if ( txexpr-attrs? x1 ) x1 ( get-attrs x1 ) ) ) )
( define attrs-tx2 ( attrs->hash ( if ( txexpr-attrs? x2 ) x2 ( get-attrs x2 ) ) ) )
( define attrs-tx2 ( attrs->hash ( if ( txexpr-attrs? x2 ) x2 ( get-attrs x2 ) ) ) )
( and
( and
@ -152,41 +224,41 @@
( equal? ( hash-ref attrs-tx2 key ) value ) ) ) )
( equal? ( hash-ref attrs-tx2 key ) value ) ) ) )
( define /typed ( attr-set tx key value )
( define +provide+safe ( attr-set tx key value )
( Txexpr Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value -> Txexpr )
( txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr? )
( define new-attrs
( define new-attrs
( hash->attrs ( hash-set ( attrs->hash ( get-attrs tx ) ) ( ->txexpr-attr-key key ) ( ->txexpr-attr-value value ) ) ) )
( hash->attrs ( hash-set ( attrs->hash ( get-attrs tx ) ) ( ->txexpr-attr-key key ) ( ->txexpr-attr-value value ) ) ) )
( make-txexpr ( get-tag tx ) new-attrs ( get-elements tx ) ) )
( make-txexpr ( get-tag tx ) new-attrs ( get-elements tx ) ) )
( define /typed ( attr-ref tx key )
( define +provide+safe ( attr-ref tx key )
( Txexpr Can-Be-Txexpr-Attr-Key -> Txexpr-Attr-Value )
( txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-value? )
( with-handlers ( [ exn:fail? ( λ ( e ) ( error ( format " attr-ref: no value found for key ~v " key ) ) ) ] )
( with-handlers ( [ exn:fail? ( λ ( e ) ( error ( format " attr-ref: no value found for key ~v " key ) ) ) ] )
( hash-ref ( attrs->hash ( get-attrs tx ) ) ( ->txexpr-attr-key key ) ) ) )
( hash-ref ( attrs->hash ( get-attrs tx ) ) ( ->txexpr-attr-key key ) ) ) )
( define /typed ( attr-ref* tx key )
( define +provide+safe ( attr-ref* tx key )
( Txexpr Can-Be-Txexpr-Attr-Key -> ( Listof Txexpr-Attr-Value ) )
( txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-values? )
( define: results : ( Listof Txexpr-Attr-Value ) empty )
( define results empty )
( let: loop : Void ( [ tx : Xexpr tx ] )
( let loop ( [ tx tx ] )
( when ( and ( txexpr? tx ) ( attrs-have-key? tx key ) ( attr-ref tx key ) )
( when ( and ( txexpr? tx ) ( attrs-have-key? tx key ) ( attr-ref tx key ) )
( set! results ( cons ( attr-ref tx key ) results ) )
( set! results ( cons ( attr-ref tx key ) results ) )
( map ( λ: ( [ e : Txexpr-Element ] ) ( loop e ) ) ( get-elements tx ) )
( map ( λ ( e ) ( loop e ) ) ( get-elements tx ) )
( void ) ) )
( void ) ) )
( reverse results ) )
( reverse results ) )
;; convert list of alternating keys & values to attr
;; convert list of alternating keys & values to attr
( define /typed ( merge-attrs . items )
( define +provide+safe ( merge-attrs . items )
( Can-Be-Txexpr-Attr * -> Txexpr-Attrs )
( ( ) #:rest list-of-can-be-txexpr-attrs? . ->* . txexpr-attrs? )
( define attrs-hash ( apply attrs->hash items ) )
( define attrs-hash ( apply attrs->hash items ) )
;; sort needed for predictable results for unit tests
;; sort needed for predictable results for unit tests
( define sorted-hash-keys ( sort ( hash-keys attrs-hash ) ( λ: ( [ a : Txexpr-Tag ] [ b : Txexpr-Tag ] ) ( string<? ( ->string a ) ( ->string b ) ) ) ) )
( define sorted-hash-keys ( sort ( hash-keys attrs-hash ) ( λ ( a b ) ( string<? ( ->string a ) ( ->string b ) ) ) ) )
` ( ,@ ( map ( λ: ( [ key : Txexpr-Tag ] ) ( list key ( hash-ref attrs-hash key ) ) ) sorted-hash-keys ) ) )
` ( ,@ ( map ( λ ( key ) ( list key ( hash-ref attrs-hash key ) ) ) sorted-hash-keys ) ) )
( define /typed ( remove-attrs x )
( define +provide+safe ( remove-attrs x )
( Xexpr -> Xexpr )
( txexpr? . -> . txexpr? )
( if ( txexpr? x )
( if ( txexpr? x )
( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
( make-txexpr tag null ( map remove-attrs elements ) ) )
( make-txexpr tag null ( map remove-attrs elements ) ) )
@ -194,58 +266,54 @@
( define /typed ( map-elements/exclude proc x exclude-test )
( define +provide+safe ( map-elements/exclude proc x exclude-test )
( ( Xexpr -> Xexpr ) Xexpr ( Xexpr -> Boolean ) -> Xexpr )
( procedure? txexpr? procedure? . -> . txexpr? )
( cond
( cond
[ ( txexpr? x )
[ ( txexpr? x )
( if ( exclude-test x )
( if ( exclude-test x )
x
x
( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
( make-txexpr tag attr
( make-txexpr tag attr
( map ( λ: ( [ x : Xexpr ] ) ( map-elements/exclude proc x exclude-test ) ) elements ) ) ) ) ]
( map ( λ ( x ) ( map-elements/exclude proc x exclude-test ) ) elements ) ) ) ) ]
;; externally the function only accepts txexpr,
;; externally the function only accepts txexpr,
;; but internally we don't care
;; but internally we don't care
[ else ( proc x ) ] ) )
[ else ( proc x ) ] ) )
( define /typed ( map-elements proc x )
( define +provide+safe ( map-elements proc x )
( ( Xexpr -> Xexpr ) Xexpr -> Xexpr )
( procedure? txexpr? . -> . txexpr? )
( map-elements/exclude proc x ( λ ( x ) #f ) ) )
( map-elements/exclude proc x ( λ ( x ) #f ) ) )
;; function to split tag out of txexpr
;; function to split tag out of txexpr
( define deleted-signal ( gensym ) )
( define deleted-signal ( gensym ) )
( define/typed ( splitf-txexpr tx pred [ proc ( λ: ( [ x : Xexpr ] ) deleted-signal ) ] )
( define+provide+safe ( splitf-txexpr tx pred [ proc ( λ ( x ) deleted-signal ) ] )
( case-> ( Txexpr ( Xexpr -> Boolean ) -> ( values Txexpr Txexpr-Elements ) )
( ( txexpr? procedure? ) ( procedure? ) . ->* . ( values txexpr? txexpr-elements? ) )
( Txexpr ( Xexpr -> Boolean ) ( Xexpr -> Xexpr ) -> ( values Txexpr Txexpr-Elements ) ) )
( define matches null )
( define: matches : Txexpr-Elements null )
( define ( do-extraction x )
( define/typed ( do-extraction x )
( Xexpr -> Xexpr )
( cond
( cond
[ ( pred x ) ( begin ; store matched item and return processed value
[ ( pred x ) ( begin ; store matched item and return processed value
( set! matches ( cons x matches ) )
( set! matches ( cons x matches ) )
( proc x ) ) ]
( proc x ) ) ]
[ ( txexpr? x ) ( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
[ ( txexpr? x ) ( let-values ( [ ( tag attr elements ) ( txexpr->values x ) ] )
( make-txexpr tag attr ( filter ( λ: ( [ e : Xexpr ] ) ( not ( equal? e deleted-signal ) ) ) ( map do-extraction elements ) ) ) ) ]
( make-txexpr tag attr ( filter ( λ ( e ) ( not ( equal? e deleted-signal ) ) ) ( map do-extraction elements ) ) ) ) ]
[ else x ] ) )
[ else x ] ) )
( define: tx-extracted : Xexpr ( do-extraction tx ) ) ;; do this first to fill matches
( define tx-extracted ( do-extraction tx ) ) ;; do this first to fill matches
( values ( if ( txexpr? tx-extracted )
( values ( if ( txexpr? tx-extracted )
tx-extracted
tx-extracted
( error ' splitf-txexpr " Bad input " ) ) ( reverse matches ) ) )
( error ' splitf-txexpr " Bad input " ) ) ( reverse matches ) ) )
( define/typed ( xexpr->html x )
( define+provide+safe ( xexpr->html x )
( Xexpr -> String )
( xexpr? . -> . string? )
( define/typed ( ->cdata x )
( define ( ->cdata x )
( Xexpr -> Xexpr )
( cond
( cond
[ ( cdata? x ) x ]
[ ( cdata? x ) x ]
[ ( string? x ) ( cdata #f #f x ) ] ; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
[ ( string? x ) ( cdata #f #f x ) ] ; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
[ else x ] ) )
[ else x ] ) )
( xexpr->string ( let: loop : Xexpr ( [ x : Xexpr x ] )
( xexpr->string ( let loop ( [ x x ] )
( cond
( cond
[ ( txexpr? x ) ( if ( member ( get-tag x ) ' ( script style ) )
[ ( txexpr? x ) ( if ( member ( get-tag x ) ' ( script style ) )
( make-txexpr ( get-tag x ) ( get-attrs x ) ( map ->cdata ( get-elements x ) ) )
( make-txexpr ( get-tag x ) ( get-attrs x ) ( map ->cdata ( get-elements x ) ) )
( make-txexpr ( get-tag x ) ( get-attrs x ) ( map loop ( get-elements x ) ) ) ) ]
( make-txexpr ( get-tag x ) ( get-attrs x ) ( map loop ( get-elements x ) ) ) ) ]
[ else x ] ) ) ) )
[ else x ] ) ) ) )