Speeding up xml.literals by 3x using code generation
Daniel Ehrenberg
parent
c7a070ba8e
commit
fa0d5de2e4
|
|
@ -55,7 +55,7 @@ IN: xml.literals.tests
|
|||
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
|
||||
|
||||
\ <XML must-infer
|
||||
[ { } "" interpolate-xml ] must-infer
|
||||
[ [XML <-> XML] ] must-infer
|
||||
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
|
||||
|
||||
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,11 +3,34 @@
|
|||
USING: xml xml.state kernel sequences fry assocs xml.data
|
||||
accessors strings make multiline parser namespaces macros
|
||||
sequences.deep generalizations words combinators
|
||||
math present arrays unicode.categories ;
|
||||
math present arrays unicode.categories locals.backend
|
||||
quotations ;
|
||||
IN: xml.literals
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: each-attrs ( attrs quot -- )
|
||||
[ values [ interpolated? ] filter ] dip each ; inline
|
||||
|
||||
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
|
||||
{
|
||||
{ [ over interpolated? ] [ call ] }
|
||||
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
|
||||
{ [ over attrs? ] [ each-attrs ] }
|
||||
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
|
||||
[ 2drop ]
|
||||
} cond ; inline recursive
|
||||
|
||||
: each-interpolated ( xml quot -- )
|
||||
'[ _ (each-interpolated) ] deep-each ; inline
|
||||
|
||||
: has-interpolated? ( xml -- ? )
|
||||
! If this becomes a performance problem, it can be improved
|
||||
f swap [ 2drop t ] each-interpolated ;
|
||||
|
||||
: when-interpolated ( xml quot -- genquot )
|
||||
[ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
|
||||
|
||||
: string>chunk ( string -- chunk )
|
||||
t interpolating? [ string>xml-chunk ] with-variable ;
|
||||
|
||||
|
|
@ -16,17 +39,34 @@ IN: xml.literals
|
|||
|
||||
DEFER: interpolate-sequence
|
||||
|
||||
: interpolate-attrs ( table attrs -- attrs )
|
||||
swap '[
|
||||
dup interpolated?
|
||||
[ var>> _ at dup [ present ] when ] when
|
||||
] assoc-map [ nip ] assoc-filter ;
|
||||
: get-interpolated ( interpolated -- quot )
|
||||
var>> '[ [ _ swap at ] keep ] ;
|
||||
|
||||
: interpolate-tag ( table tag -- tag )
|
||||
[ nip name>> ]
|
||||
[ attrs>> interpolate-attrs ]
|
||||
[ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri
|
||||
<tag> ;
|
||||
: ?present ( object -- string )
|
||||
dup [ present ] when ;
|
||||
|
||||
: interpolate-attr ( key value -- quot )
|
||||
dup interpolated?
|
||||
[ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
|
||||
[ 2array '[ _ swap ] ] if ;
|
||||
|
||||
: filter-nulls ( assoc -- newassoc )
|
||||
[ nip ] assoc-filter ;
|
||||
|
||||
: interpolate-attrs ( attrs -- quot )
|
||||
[
|
||||
[ [ interpolate-attr ] { } assoc>map [ ] join ]
|
||||
[ assoc-size ] bi
|
||||
'[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
: interpolate-tag ( tag -- quot )
|
||||
[
|
||||
[ name>> ]
|
||||
[ attrs>> interpolate-attrs ]
|
||||
[ children>> interpolate-sequence ] tri
|
||||
'[ _ swap @ @ [ <tag> ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
GENERIC: push-item ( item -- )
|
||||
M: string push-item , ;
|
||||
|
|
@ -37,30 +77,33 @@ M: sequence push-item
|
|||
M: number push-item present , ;
|
||||
M: xml-chunk push-item % ;
|
||||
|
||||
GENERIC: interpolate-item ( table item -- )
|
||||
M: object interpolate-item nip , ;
|
||||
M: tag interpolate-item interpolate-tag , ;
|
||||
M: interpolated interpolate-item
|
||||
var>> swap at push-item ;
|
||||
: concat-interpolate ( array -- newarray )
|
||||
[ [ push-item ] each ] { } make ;
|
||||
|
||||
: interpolate-sequence ( table seq -- seq )
|
||||
[ [ interpolate-item ] with each ] { } make ;
|
||||
GENERIC: interpolate-item ( item -- quot )
|
||||
M: object interpolate-item [ swap ] curry ;
|
||||
M: tag interpolate-item interpolate-tag ;
|
||||
M: interpolated interpolate-item get-interpolated ;
|
||||
|
||||
: interpolate-xml-doc ( table xml -- xml )
|
||||
(clone) [ interpolate-tag ] change-body ;
|
||||
: interpolate-sequence ( seq -- quot )
|
||||
[
|
||||
[ [ interpolate-item ] map concat ]
|
||||
[ length ] bi
|
||||
'[ @ _ swap [ narray concat-interpolate ] dip ]
|
||||
] when-interpolated ;
|
||||
|
||||
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
|
||||
{
|
||||
{ [ over interpolated? ] [ call ] }
|
||||
{ [ over tag? ] [
|
||||
[ attrs>> values [ interpolated? ] filter ] dip each
|
||||
] }
|
||||
{ [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
|
||||
[ 2drop ]
|
||||
} cond ; inline recursive
|
||||
GENERIC: [interpolate-xml] ( xml -- quot )
|
||||
|
||||
: each-interpolated ( xml quot -- )
|
||||
'[ _ (each-interpolated) ] deep-each ; inline
|
||||
M: xml [interpolate-xml]
|
||||
dup body>> interpolate-tag
|
||||
'[ _ (clone) swap @ drop >>body ] ;
|
||||
|
||||
M: xml-chunk [interpolate-xml]
|
||||
interpolate-sequence
|
||||
'[ @ drop <xml-chunk> ] ;
|
||||
|
||||
MACRO: interpolate-xml ( xml -- quot )
|
||||
[interpolate-xml] ;
|
||||
|
||||
: number<-> ( doc -- dup )
|
||||
0 over [
|
||||
|
|
@ -69,14 +112,6 @@ M: interpolated interpolate-item
|
|||
] unless drop
|
||||
] each-interpolated drop ;
|
||||
|
||||
GENERIC: interpolate-xml ( table xml -- xml )
|
||||
|
||||
M: xml interpolate-xml
|
||||
interpolate-xml-doc ;
|
||||
|
||||
M: xml-chunk interpolate-xml
|
||||
interpolate-sequence <xml-chunk> ;
|
||||
|
||||
: >search-hash ( seq -- hash )
|
||||
[ dup search ] H{ } map>assoc ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue