! 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