: sql-row-typed ( result-set -- seq )
dup #columns [ row-column-typed ] with map ;
-: query-each ( statement quot -- )
+: query-each ( statement quot: ( statement -- ) -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
2drop
- ] if ; inline
+ ] if ; inline recursive
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
: query-make ( class quot -- )
>r sql-props r>
- [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+ [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
+ dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
- dup name-tag dup tags get at
+ dup main>> dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
- [ name-tag >lower tag-stack get push ]
+ [ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
} cleave ;
: expand-attrs ( tag -- tag )
- dup [ tag? ] is? [
+ dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
: process-template ( xml -- )
expand-attrs
{
- { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
- { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ dup chloe-tag? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
IN: namespaces.lib.tests\r
-USING: namespaces.lib tools.test ;\r
+USING: namespaces.lib kernel tools.test ;\r
\r
[ ] [ [ ] { } nmake ] unit-test\r
\r
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test\r
+\r
+[ [ ] [ call ] curry { { } } nmake ] must-infer\r
-
-! USING: kernel quotations namespaces sequences assocs.lib ;
-
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math generalizations locals mirrors ;
+ assocs.lib math.parser math generalizations locals mirrors
+ macros ;
IN: namespaces.lib
: 4% ( seq -- ) 4 n% ;
: 4# ( num -- ) 4 n# ;
-MACRO:: nmake ( quot exemplars -- )
- [let | n [ exemplars length ] |
- [
- [
- exemplars
- [ 0 swap new-resizable ] map
- building-seq set
-
- quot call
-
- building-seq get
- exemplars [ like ] 2map
- n firstn
- ] with-scope
- ]
- ] ;
+MACRO: finish-nmake ( exemplars -- )
+ length [ firstn ] curry ;
+
+:: nmake ( quot exemplars -- )
+ [
+ exemplars
+ [ 0 swap new-resizable ] map
+ building-seq set
+
+ quot call
+
+ building-seq get
+ exemplars [ [ like ] 2map ] [ finish-nmake ] bi
+ ] with-scope ; inline
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline
-USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
+USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data
xml.utilities xml assocs kernel combinators sequences
math.parser namespaces parser lexer xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
! Rule tag parsing utilities
: (parse-rule-tag) ( rule-set tag specs class -- )
- construct-rule swap init-from-tag swap add-rule ; inline
+ new swap init-from-tag swap add-rule ; inline
: RULE:
scan scan-word
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
- >r dup name-tag string>token swap children>string r> set-at ;
+ >r dup main>> string>token swap children>string r> set-at ;
-USING: kernel ;
+USING: accessors kernel ;
IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
: <line-context> ( ruleset parent -- line-context )
over [ "no context" throw ] unless
- { set-line-context-in-rule-set set-line-context-parent }
- line-context construct ;
+ line-context new
+ swap >>parent
+ swap >>in-rule-set ;
M: line-context clone
- (clone)
- dup line-context-parent clone
- over set-line-context-parent ;
+ call-next-method [ clone ] change-parent ;
chars
;
-: construct-rule ( class -- rule )
- >r rule new r> construct-delegate ; inline
+TUPLE: seq-rule < rule ;
-TUPLE: seq-rule ;
+TUPLE: span-rule < rule ;
-TUPLE: span-rule ;
-
-TUPLE: eol-span-rule ;
+TUPLE: eol-span-rule < rule ;
: init-span ( rule -- )
dup rule-delegate [ drop ] [
dup init-span
t swap set-rule-no-line-break? ;
-TUPLE: mark-following-rule ;
+TUPLE: mark-following-rule < rule ;
-TUPLE: mark-previous-rule ;
+TUPLE: mark-previous-rule < rule ;
-TUPLE: escape-rule ;
+TUPLE: escape-rule < rule ;
: <escape-rule> ( string -- rule )
f <string-matcher> f f f <matcher>
- escape-rule construct-rule
- [ set-rule-start ] keep ;
+ escape-rule new swap >>start ;
GENERIC: text-hash-char ( text -- ch )
IN: xmode.utilities.tests
-USING: xmode.utilities tools.test xml xml.data kernel strings
-vectors sequences io.files prettyprint assocs unicode.case ;
-
+USING: accessors xmode.utilities tools.test xml xml.data kernel
+strings vectors sequences io.files prettyprint assocs
+unicode.case ;
[ "hi" 3 ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
] unit-test
{ { "type" >upper set-company-type } }
init-from-tag dup
] keep
- tag-children [ tag? ] filter
+ children>> [ tag? ] filter
[ parse-employee-tag ] with each ;
[
-USING: sequences assocs kernel quotations namespaces xml.data
-xml.utilities combinators macros parser lexer words ;
+USING: accessors sequences assocs kernel quotations namespaces
+xml.data xml.utilities combinators macros parser lexer words ;
IN: xmode.utilities
: implies >r not r> or ; inline
-: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
+: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
: TAGS>
tag-handler-word get
- tag-handlers get >alist [ >r dup name-tag r> case ] curry
+ tag-handlers get >alist [ >r dup main>> r> case ] curry
define ; parsing