Paste: TAG-NS:

Author:	tizoc
Mode:	factor
Date:	Sun, 19 Apr 2009 21:46:30

Plain Text |

Delete Paste

diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor
index f395920..f41f17e 100644
--- a/basis/xml/syntax/syntax.factor
+++ b/basis/xml/syntax/syntax.factor
@@ -5,7 +5,7 @@ sequences summary lexer splitting combinators locals xml.data
 memoize sequences.deep xml.data xml.state xml namespaces present
 arrays generalizations strings make math macros multiline
 inverse combinators.short-circuit sorting fry unicode.categories
-effects ;
+effects hashtables ;
 IN: xml.syntax
 
 <PRIVATE
@@ -14,15 +14,21 @@ TUPLE: no-tag name word ;
 M: no-tag summary
     drop "The tag-dispatching word has no method for the given tag name" ;
 
+: build-cases ( key hashtable -- key quot )
+    >alist 2dup delete-at* [ drop [ no-tag new throw ] ] unless suffix
+    '[ dup url>> _ case ] ;
+
 : compile-tags ( word xtable -- quot )
-    >alist swap '[ _ no-tag boa throw ] suffix
+    >alist [ build-cases ] assoc-map
+    swap '[ _ no-tag boa throw ] suffix
     '[ dup main>> _ case ] ;
 
 : define-tags ( word effect -- )
     [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
 
-:: define-tag ( string word quot -- )
-    quot string word "xtable" word-prop set-at
+:: define-tag ( tag namespace word quot -- )
+    quot namespace tag word "xtable" word-prop
+    [ ?set-at ] change-at
     word word stack-effect define-tags ;
 
 PRIVATE>
@@ -34,7 +40,10 @@ SYNTAX: TAGS:
     2bi ;
 
 SYNTAX: TAG:
-    scan scan-word parse-definition define-tag ;
+    scan f scan-word parse-definition define-tag ;
+
+SYNTAX: TAG-NS:
+    scan scan scan-word parse-definition define-tag ;
 
 SYNTAX: XML-NS:
     CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;

Annotation: no diff

Author:	tizoc
Mode:	factor
Date:	Sun, 19 Apr 2009 22:23:20

Plain Text |

Delete Annotation

! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser effects.parser
sequences summary lexer splitting combinators locals xml.data
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
inverse combinators.short-circuit sorting fry unicode.categories
effects hashtables ;
IN: xml.syntax

<PRIVATE

TUPLE: no-tag name word ;
M: no-tag summary
    drop "The tag-dispatching word has no method for the given tag name" ;

: make-namespace-case ( key hashtable -- key quot )
    >alist 2dup delete-at* [ drop [ no-tag new throw ] ] unless suffix
    '[ dup url>> _ case ] ;

: compile-tags ( word xtable -- quot )
    >alist [ make-namespace-case ] assoc-map
    swap '[ _ no-tag boa throw ] suffix
    '[ dup main>> _ case ] ;

: define-tags ( word effect -- )
    [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;

:: define-tag ( tag namespace word quot -- )
    quot namespace tag word "xtable" word-prop
    [ ?set-at ] change-at
    word word stack-effect define-tags ;

PRIVATE>

SYNTAX: TAGS:
    CREATE-WORD complete-effect
    [ drop H{ } clone "xtable" set-word-prop ]
    [ define-tags ]
    2bi ;

SYNTAX: TAG:
    scan f scan-word parse-definition define-tag ;

SYNTAX: TAG-NS:
    scan scan scan-word parse-definition define-tag ;

Annotation: TAG-NS:

Author:	tizoc
Mode:	factor
Date:	Sun, 19 Apr 2009 22:32:56

Plain Text |

Delete Annotation

! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser effects.parser
sequences summary lexer splitting combinators locals xml.data
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
inverse combinators.short-circuit sorting fry unicode.categories
effects hashtables ;
IN: xml.syntax

<PRIVATE

TUPLE: no-tag name word ;
M: no-tag summary
    drop "The tag-dispatching word has no method for the given tag name" ;

: build-cases ( key hashtable -- key quot )
    >alist 2dup delete-at* [ drop [ no-tag new throw ] ] unless suffix
    '[ dup url>> _ case ] ;

: compile-tags ( word xtable -- quot )
    >alist [ build-cases ] assoc-map
    swap '[ _ no-tag boa throw ] suffix
    '[ dup main>> _ case ] ;

: define-tags ( word effect -- )
    [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;

:: define-tag ( tag namespace word quot -- )
    quot namespace tag word "xtable" word-prop
    [ ?set-at ] change-at
    word word stack-effect define-tags ;

PRIVATE>

SYNTAX: TAGS:
    CREATE-WORD complete-effect
    [ drop H{ } clone "xtable" set-word-prop ]
    [ define-tags ]
    2bi ;

SYNTAX: TAG:
    scan f scan-word parse-definition define-tag ;

SYNTAX: TAG-NS:
    scan scan scan-word parse-definition define-tag ;

SYNTAX: XML-NS:
    CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;

Annotation: without hashes

Author:	tizoc
Mode:	factor
Date:	Mon, 20 Apr 2009 00:07:29

Plain Text |

Delete Annotation

! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: words assocs kernel accessors parser effects.parser
sequences summary lexer splitting combinators locals xml.data
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
inverse combinators.short-circuit sorting fry unicode.categories
effects ;
IN: xml.syntax

<PRIVATE

TUPLE: no-tag name word ;
M: no-tag summary
    drop "The tag-dispatching word has no method for the given tag name" ;

TUPLE: no-tag-namespace < no-tag url ;

TUPLE: ns-matcher urls fallback ;
: <ns-matcher> ( name word -- ns-matcher )
    '[ [ _ _ ] dip no-tag-namespace boa throw ]
    ns-matcher new
        swap >>fallback
        H{ } clone >>urls ;

: add-match ( quot url ns-matcher -- )
    swap [ swap urls>> set-at ] [ [ [ drop ] prepose ] dip (>>fallback) ] if* ;

: build-case ( key hashtable -- key quot )
    [ urls>> >alist ] [ fallback>> ] bi
    suffix '[ dup url>> _ case ] ;

: compile-tags ( word xtable -- quot )
    >alist [ build-case ] assoc-map
    swap '[ _ no-tag boa throw ] suffix
    '[ dup main>> _ case ] ;

: define-tags ( word effect -- )
    [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;

:: define-tag ( name url word quot -- )
    quot url name word "xtable" word-prop
    [ [ ] [ name word <ns-matcher> ] if* [ add-match ] keep ] change-at
    word word stack-effect define-tags ;

PRIVATE>

SYNTAX: TAGS:
    CREATE-WORD complete-effect
    [ drop H{ } clone "xtable" set-word-prop ]
    [ define-tags ]
    2bi ;

SYNTAX: TAG:
    scan f scan-word parse-definition define-tag ;

SYNTAX: TAG-NS:
    scan scan scan-word parse-definition define-tag ;

SYNTAX: XML-NS:
    CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;

! --- tests

TAGS: process-nstag ( tag -- namespace )
TAG: tagname process-nstag drop "fallback" ;
TAG-NS: tagname namespace1 process-nstag drop "namespace1" ;
TAG-NS: tagname namespace2 process-nstag drop "namespace2" ;

[ "namespace1" ] [ "" "tagname" "namespace1" <name> process-nstag ] unit-test
[ "fallback" ] [ "" "tagname" "namespace3" <name> process-nstag ] unit-test

New Annotation

Summary:
Author:
Mode:	textPostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonqdocrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsparqlsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done