From b9839b0c320d5962ac2568b437c3adbd5fe00ae6 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 5 Feb 2009 14:21:36 -0600 Subject: [PATCH] XML literals work with inverse now --- {extra => basis}/inverse/authors.txt | 0 {extra => basis}/inverse/inverse-docs.factor | 0 {extra => basis}/inverse/inverse-tests.factor | 0 {extra => basis}/inverse/inverse.factor | 0 {extra => basis}/inverse/summary.txt | 0 {extra => basis}/inverse/tags.txt | 0 basis/xml/literals/literals-tests.factor | 34 +++++++++ basis/xml/literals/literals.factor | 70 +++++++++++++++++++ 8 files changed, 104 insertions(+) rename {extra => basis}/inverse/authors.txt (100%) rename {extra => basis}/inverse/inverse-docs.factor (100%) rename {extra => basis}/inverse/inverse-tests.factor (100%) rename {extra => basis}/inverse/inverse.factor (100%) rename {extra => basis}/inverse/summary.txt (100%) rename {extra => basis}/inverse/tags.txt (100%) diff --git a/extra/inverse/authors.txt b/basis/inverse/authors.txt similarity index 100% rename from extra/inverse/authors.txt rename to basis/inverse/authors.txt diff --git a/extra/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor similarity index 100% rename from extra/inverse/inverse-docs.factor rename to basis/inverse/inverse-docs.factor diff --git a/extra/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor similarity index 100% rename from extra/inverse/inverse-tests.factor rename to basis/inverse/inverse-tests.factor diff --git a/extra/inverse/inverse.factor b/basis/inverse/inverse.factor similarity index 100% rename from extra/inverse/inverse.factor rename to basis/inverse/inverse.factor diff --git a/extra/inverse/summary.txt b/basis/inverse/summary.txt similarity index 100% rename from extra/inverse/summary.txt rename to basis/inverse/summary.txt diff --git a/extra/inverse/tags.txt b/basis/inverse/tags.txt similarity index 100% rename from extra/inverse/tags.txt rename to basis/inverse/tags.txt diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor index ec68a034a6..0d8367c144 100644 --- a/basis/xml/literals/literals-tests.factor +++ b/basis/xml/literals/literals-tests.factor @@ -66,3 +66,37 @@ IN: xml.literals.tests [ 1 ] [ [ XML> ] length ] unit-test [ "" ] [ [XML XML] concat ] unit-test + +USE: inverse + +[ "foo" ] [ [XML foo XML] [ [XML <-> XML] ] undo ] unit-test +[ "foo" ] [ [XML XML] [ [XML /> XML] ] undo ] unit-test +[ "foo" "baz" ] [ [XML baz XML] [ [XML ><-> XML] ] undo ] unit-test + +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "byes" ] } + { [ [XML /> XML] ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ [XML pple XML] dispatch ] unit-test +[ "banana" ] [ [XML anana XML] dispatch ] unit-test +[ "byes" ] [ [XML XML] dispatch ] unit-test +[ "bnowhere" ] [ [XML XML] dispatch ] unit-test +[ "baboon" ] [ [XML aboon XML] dispatch ] unit-test +[ "apple" ] [ pple XML> dispatch ] unit-test +[ "apple" ] [ pple XML> body>> dispatch ] unit-test + +: dispatch-doc ( xml -- string ) + { + { [ <-> XML> ] [ "a" prepend ] } + { [ <-> XML> ] [ "b" prepend ] } + { [ XML> ] [ "byes" ] } + { [ /> XML> ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ pple XML> dispatch-doc ] unit-test +[ "apple" ] [ [XML pple XML] dispatch-doc ] unit-test +[ "apple" ] [ pple XML> body>> dispatch-doc ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor index 1520afdde4..4648f7b0e7 100644 --- a/basis/xml/literals/literals.factor +++ b/basis/xml/literals/literals.factor @@ -142,3 +142,73 @@ PRIVATE> : [XML "XML]" [ string>chunk ] parse-def ; parsing + +USING: inverse sorting fry combinators.short-circuit ; + +: remove-blanks ( seq -- newseq ) + [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; + +GENERIC: >xml ( xml -- tag ) +M: xml >xml body>> ; +M: tag >xml ; +M: xml-chunk >xml + remove-blanks + [ length 1 =/fail ] + [ first dup tag? [ fail ] unless ] bi ; +M: object >xml fail ; + +: 1chunk ( object -- xml-chunk ) + 1array ; + +GENERIC: >xml-chunk ( xml -- chunk ) +M: xml >xml-chunk body>> 1chunk ; +M: xml-chunk >xml-chunk ; +M: object >xml-chunk 1chunk ; + +GENERIC: [undo-xml] ( xml -- quot ) + +M: xml [undo-xml] + body>> [undo-xml] '[ >xml @ ] ; + +M: xml-chunk [undo-xml] + seq>> [undo-xml] '[ >xml-chunk @ ] ; + +: undo-attrs ( attrs -- quot: ( attrs -- ) ) + [ + [ main>> ] dip dup interpolated? + [ var>> '[ _ attr _ set ] ] + [ '[ _ attr _ =/fail ] ] if + ] { } assoc>map '[ _ cleave ] ; + +M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) + { + [ name>> main>> '[ name>> main>> _ =/fail ] ] + [ attrs>> undo-attrs ] + [ children>> [undo-xml] '[ children>> @ ] ] + } cleave '[ _ _ _ tri ] ; + +: firstn-strong ( seq n -- ... ) + [ swap length =/fail ] + [ firstn ] 2bi ; inline + +M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) ) + remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi + '[ remove-blanks _ firstn-strong _ spread ] ; + +M: string [undo-xml] ( string -- quot: ( string -- ) ) + '[ _ =/fail ] ; + +M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) ) + '[ _ =/fail ] ; + +M: interpolated [undo-xml] + var>> '[ _ set ] ; + +: >enum ( assoc -- enum ) + ! Assumes keys are 0..n + >alist sort-keys values ; + +: undo-xml ( xml -- quot ) + [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; + +\ interpolate-xml 1 [ undo-xml ] define-pop-inverse