if-empty changes
parent
e0f7e508aa
commit
8a921c791c
|
@ -36,7 +36,7 @@ PRIVATE>
|
|||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - cut
|
||||
[ 3 <groups> [ encode3 ] map concat ]
|
||||
[ dup empty? [ drop "" ] [ >base64-rem ] if ]
|
||||
[ [ "" ] [ >base64-rem ] if-empty ]
|
||||
bi* append ;
|
||||
|
||||
: base64> ( base64 -- str )
|
||||
|
|
|
@ -33,10 +33,10 @@ PRIVATE>
|
|||
|
||||
M: channel to ( value channel -- )
|
||||
dup receivers>>
|
||||
dup empty? [ drop dup wait to ] [ nip (to) ] if ;
|
||||
[ dup wait to ] [ nip (to) ] if-empty ;
|
||||
|
||||
M: channel from ( channel -- value )
|
||||
[
|
||||
notify senders>>
|
||||
dup empty? [ drop ] [ (from) ] if
|
||||
[ (from) ] unless-empty
|
||||
] curry "channel receive" suspend ;
|
||||
|
|
|
@ -120,7 +120,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
|
|||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
|
|
|
@ -28,18 +28,18 @@ DEFER: (tail-call?)
|
|||
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
|
||||
|
||||
: (tail-call?) ( cursor -- ? )
|
||||
dup empty? [ drop t ] [
|
||||
[ t ] [
|
||||
[ first [ #return? ] [ #terminate? ] bi or ]
|
||||
[ tail-phi? ]
|
||||
bi or
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get [
|
||||
rest-slice
|
||||
dup empty? [ drop t ] [
|
||||
[ t ] [
|
||||
[ (tail-call?) ]
|
||||
[ first #terminate? not ]
|
||||
bi and
|
||||
] if
|
||||
] if-empty
|
||||
] all? ;
|
||||
|
|
|
@ -32,7 +32,7 @@ M: #shuffle check-node*
|
|||
M: #copy check-node* inputs/outputs 2array check-lengths ;
|
||||
|
||||
: check->r/r> ( node -- )
|
||||
inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
|
||||
inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
|
||||
|
||||
M: #>r check-node* check->r/r> ;
|
||||
|
||||
|
|
|
@ -37,8 +37,8 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
[ cleanup* ] map flatten ;
|
||||
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos dup empty?
|
||||
[ drop f ] [ [ literal?>> ] all? ] if ;
|
||||
node-output-infos
|
||||
[ f ] [ [ literal?>> ] all? ] if-empty ;
|
||||
|
||||
: cleanup-folding ( #call -- nodes )
|
||||
#! Replace a #call having a known result with a #drop of its
|
||||
|
|
|
@ -15,7 +15,7 @@ M: #branch escape-analysis*
|
|||
|
||||
: (merge-allocations) ( values -- allocation )
|
||||
[
|
||||
dup [ allocation ] map sift dup empty? [ 2drop f ] [
|
||||
dup [ allocation ] map sift [ drop f ] [
|
||||
dup [ t eq? not ] all? [
|
||||
dup [ length ] map all-equal? [
|
||||
nip flip
|
||||
|
@ -23,7 +23,7 @@ M: #branch escape-analysis*
|
|||
[ record-allocations ] keep
|
||||
] [ drop add-escaping-values t ] if
|
||||
] [ drop add-escaping-values t ] if
|
||||
] if
|
||||
] if-empty
|
||||
] map ;
|
||||
|
||||
: merge-allocations ( in-values out-values -- )
|
||||
|
|
|
@ -205,5 +205,5 @@ M: node normalize* ;
|
|||
dup [ collect-label-info ] each-node
|
||||
dup count-introductions make-values
|
||||
[ (normalize) ] [ nip ] 2bi
|
||||
dup empty? [ drop ] [ #introduce prefix ] if
|
||||
[ #introduce prefix ] unless-empty
|
||||
rename-node-values ;
|
||||
|
|
|
@ -237,9 +237,8 @@ DEFER: (value-info-union)
|
|||
} cond ;
|
||||
|
||||
: value-infos-union ( infos -- info )
|
||||
dup empty?
|
||||
[ drop null-info ]
|
||||
[ dup first [ value-info-union ] reduce ] if ;
|
||||
[ null-info ]
|
||||
[ dup first [ value-info-union ] reduce ] if-empty ;
|
||||
|
||||
: literals<= ( info1 info2 -- ? )
|
||||
{
|
||||
|
|
|
@ -185,7 +185,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
|
|||
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
|
||||
|
||||
: ends-with-terminate? ( nodes -- ? )
|
||||
dup empty? [ drop f ] [ peek #terminate? ] if ;
|
||||
[ f ] [ peek #terminate? ] if-empty ;
|
||||
|
||||
M: vector child-visitor V{ } clone ;
|
||||
M: vector #introduce, #introduce node, ;
|
||||
|
|
|
@ -87,11 +87,11 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
{ URL [ dup [ present ] when default-param-value ] }
|
||||
[ drop default-param-value ]
|
||||
} case 2array
|
||||
] 2map flip dup empty? [
|
||||
drop f f
|
||||
] 2map flip [
|
||||
f f
|
||||
] [
|
||||
first2 [ >c-void*-array ] [ >c-uint-array ] bi*
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: param-formats ( statement -- seq )
|
||||
in-params>> [ type>> type>param-format ] map >c-uint-array ;
|
||||
|
|
|
@ -136,7 +136,7 @@ ERROR: no-sql-type ;
|
|||
|
||||
: modifiers ( spec -- string )
|
||||
modifiers>> [ lookup-modifier ] map " " join
|
||||
dup empty? [ " " prepend ] unless ;
|
||||
[ "" ] [ " " prepend ] if-empty ;
|
||||
|
||||
HOOK: bind% db ( spec -- )
|
||||
HOOK: bind# db ( spec obj -- )
|
||||
|
|
|
@ -48,14 +48,12 @@ M: string error. print ;
|
|||
] "" make print ;
|
||||
|
||||
: restarts. ( -- )
|
||||
restarts get dup empty? [
|
||||
drop
|
||||
] [
|
||||
restarts get [
|
||||
nl
|
||||
"The following restarts are available:" print
|
||||
nl
|
||||
[ restart. ] each-index
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: print-error ( error -- )
|
||||
[ error. flush ] curry
|
||||
|
|
|
@ -14,13 +14,13 @@ DEFER: shallow-fry
|
|||
|
||||
: ((shallow-fry)) ( accum quot adder -- result )
|
||||
>r shallow-fry r>
|
||||
append swap dup empty? [ drop ] [
|
||||
append swap [
|
||||
[ prepose ] curry append
|
||||
] if ; inline
|
||||
] unless-empty ; inline
|
||||
|
||||
: (shallow-fry) ( accum quot -- result )
|
||||
dup empty? [
|
||||
drop 1quotation
|
||||
[
|
||||
1quotation
|
||||
] [
|
||||
unclip {
|
||||
{ \ , [ [ curry ] ((shallow-fry)) ] }
|
||||
|
@ -31,7 +31,7 @@ DEFER: shallow-fry
|
|||
|
||||
[ swap >r suffix r> (shallow-fry) ]
|
||||
} case
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
|
||||
|
||||
|
|
|
@ -23,11 +23,11 @@ SYMBOL: rest
|
|||
|
||||
: render-validation-messages ( -- )
|
||||
form get errors>>
|
||||
dup empty? [ drop ] [
|
||||
[
|
||||
<ul "errors" =class ul>
|
||||
[ <li> escape-string write </li> ] each
|
||||
</ul>
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
CHLOE: validation-messages drop render-validation-messages ;
|
||||
|
||||
|
@ -47,11 +47,11 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
2tri ;
|
||||
|
||||
: set-nested-form ( form name -- )
|
||||
dup empty? [
|
||||
drop merge-forms
|
||||
[
|
||||
merge-forms
|
||||
] [
|
||||
unclip [ set-nested-form ] nest-form
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: restore-validation-errors ( -- )
|
||||
form cget [
|
||||
|
|
|
@ -42,8 +42,8 @@ IN: furnace.auth.features.edit-profile
|
|||
[
|
||||
logged-in-user get
|
||||
|
||||
"new-password" value dup empty?
|
||||
[ drop ] [ >>encoded-password ] if
|
||||
"new-password" value
|
||||
[ >>encoded-password ] unless-empty
|
||||
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
|
|
@ -112,8 +112,7 @@ SYMBOL: exit-continuation
|
|||
|
||||
! Chloe tags
|
||||
: parse-query-attr ( string -- assoc )
|
||||
dup empty?
|
||||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
|
||||
|
||||
: a-url-path ( tag -- string )
|
||||
[ "href" required-attr ]
|
||||
|
|
|
@ -72,15 +72,13 @@ M: word article-parent "help-parent" word-prop ;
|
|||
M: word set-article-parent swap "help-parent" set-word-prop ;
|
||||
|
||||
: $doc-path ( article -- )
|
||||
help-path dup empty? [
|
||||
drop
|
||||
] [
|
||||
help-path [
|
||||
[
|
||||
help-path-style get [
|
||||
"Parent topics: " write $links
|
||||
] with-style
|
||||
] ($block)
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: $title ( topic -- )
|
||||
title-style get [
|
||||
|
@ -112,8 +110,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
sort-articles [ \ $subsection swap 2array ] map print-element ;
|
||||
|
||||
: $index ( element -- )
|
||||
first call dup empty?
|
||||
[ drop ] [ ($index) ] if ;
|
||||
first call [ ($index) ] unless-empty ;
|
||||
|
||||
: $about ( element -- )
|
||||
first vocab-help [ 1array $subsection ] when* ;
|
||||
|
|
|
@ -136,15 +136,14 @@ M: help-error error.
|
|||
] with-scope ;
|
||||
|
||||
: typos. ( assoc -- )
|
||||
dup empty? [
|
||||
drop
|
||||
[
|
||||
"==== ALL CHECKS PASSED" print
|
||||
] [
|
||||
[
|
||||
swap vocab-heading.
|
||||
[ error. nl ] each
|
||||
] assoc-each
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: help-lint ( prefix -- ) run-help-lint typos. ;
|
||||
|
||||
|
|
|
@ -15,7 +15,7 @@ IN: help.markup
|
|||
! Element types are words whose name begins with $.
|
||||
|
||||
PREDICATE: simple-element < array
|
||||
dup empty? [ drop t ] [ first word? not ] if ;
|
||||
[ t ] [ first word? not ] if-empty ;
|
||||
|
||||
SYMBOL: last-element
|
||||
SYMBOL: span
|
||||
|
@ -201,8 +201,8 @@ ALIAS: $slot $snippet
|
|||
dup [ "related" set-word-prop ] curry each ;
|
||||
|
||||
: $related ( element -- )
|
||||
first dup "related" word-prop remove dup empty?
|
||||
[ drop ] [ $see-also ] if ;
|
||||
first dup "related" word-prop remove
|
||||
[ $see-also ] unless-empty ;
|
||||
|
||||
: ($grid) ( style quot -- )
|
||||
[
|
||||
|
|
|
@ -13,10 +13,10 @@ IN: hints
|
|||
dup length <reversed>
|
||||
[ (picker) 2array ] 2map
|
||||
[ drop object eq? not ] assoc-filter
|
||||
dup empty? [ drop [ t ] ] [
|
||||
[ [ t ] ] [
|
||||
[ (make-specializer) ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
|
|
|
@ -88,11 +88,11 @@ TUPLE: html-sub-stream < html-stream style parent ;
|
|||
] make-css ;
|
||||
|
||||
: span-tag ( style quot -- )
|
||||
over span-css-style dup empty? [
|
||||
drop call
|
||||
over span-css-style [
|
||||
call
|
||||
] [
|
||||
<span =style span> call </span>
|
||||
] if ; inline
|
||||
] if-empty ; inline
|
||||
|
||||
: format-html-span ( string style stream -- )
|
||||
stream>> [
|
||||
|
@ -121,11 +121,11 @@ M: html-span-stream dispose
|
|||
] make-css ;
|
||||
|
||||
: div-tag ( style quot -- )
|
||||
swap div-css-style dup empty? [
|
||||
drop call
|
||||
swap div-css-style [
|
||||
call
|
||||
] [
|
||||
<div =style div> call </div>
|
||||
] if ; inline
|
||||
] if-empty ; inline
|
||||
|
||||
: format-html-div ( string style stream -- )
|
||||
stream>> [
|
||||
|
|
|
@ -50,14 +50,14 @@ SYMBOL: +editable+
|
|||
|
||||
: describe* ( obj mirror keys -- )
|
||||
rot summary.
|
||||
dup empty? [
|
||||
2drop
|
||||
[
|
||||
drop
|
||||
] [
|
||||
dup enum? [ +sequence+ on ] when
|
||||
standard-table-style [
|
||||
swap [ -rot describe-row ] curry each-index
|
||||
] tabular-output
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: describe ( obj -- )
|
||||
dup make-mirror dup sorted-keys describe* ;
|
||||
|
|
|
@ -95,11 +95,11 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
|
|||
<PRIVATE
|
||||
|
||||
: parse-inet6 ( string -- seq )
|
||||
dup empty? [ drop f ] [
|
||||
[ f ] [
|
||||
":" split [
|
||||
hex> [ "Component not a number" throw ] unless*
|
||||
] B{ } map-as
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: pad-inet6 ( string1 string2 -- seq )
|
||||
2dup [ length ] bi@ + 8 swap -
|
||||
|
|
|
@ -3,14 +3,14 @@
|
|||
USING: lcs html.elements kernel qualified ;
|
||||
FROM: accessors => item>> ;
|
||||
FROM: io => write ;
|
||||
FROM: sequences => each empty? ;
|
||||
FROM: sequences => each if-empty ;
|
||||
FROM: xml.entities => escape-string ;
|
||||
IN: lcs.diff2html
|
||||
|
||||
GENERIC: diff-line ( obj -- )
|
||||
|
||||
: write-item ( item -- )
|
||||
item>> dup empty? [ drop " " ] [ escape-string ] if write ;
|
||||
item>> [ " " ] [ escape-string ] if-empty write ;
|
||||
|
||||
M: retain diff-line
|
||||
<tr>
|
||||
|
|
|
@ -98,8 +98,8 @@ C: <quote> quote
|
|||
UNION: special local quote local-word local-reader local-writer ;
|
||||
|
||||
: load-locals-quot ( args -- quot )
|
||||
dup empty? [
|
||||
drop [ ]
|
||||
[
|
||||
[ ]
|
||||
] [
|
||||
dup [ local-reader? ] contains? [
|
||||
<reversed> [
|
||||
|
@ -108,14 +108,10 @@ UNION: special local quote local-word local-reader local-writer ;
|
|||
] [
|
||||
length [ load-locals ] curry >quotation
|
||||
] if
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: drop-locals-quot ( args -- quot )
|
||||
dup empty? [
|
||||
drop [ ]
|
||||
] [
|
||||
length [ drop-locals ] curry
|
||||
] if ;
|
||||
[ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
|
||||
|
||||
: point-free-body ( quot args -- newquot )
|
||||
>r but-last-slice r> [ localize ] curry map concat ;
|
||||
|
|
|
@ -18,14 +18,14 @@ SYMBOL: insomniac-recipients
|
|||
] "" make ;
|
||||
|
||||
: (email-log-report) ( service word-names -- )
|
||||
dupd ?analyze-log dup empty? [ 2drop ] [
|
||||
dupd ?analyze-log [ drop ] [
|
||||
<email>
|
||||
swap >>body
|
||||
insomniac-recipients get >>to
|
||||
insomniac-sender get >>from
|
||||
swap email-subject >>subject
|
||||
send-email
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
\ (email-log-report) NOTICE add-error-logging
|
||||
|
||||
|
|
|
@ -17,9 +17,8 @@ TUPLE: history < model back forward ;
|
|||
swap value>> dup [ swap push ] [ 2drop ] if ;
|
||||
|
||||
: go-back/forward ( history to from -- )
|
||||
dup empty?
|
||||
[ 3drop ]
|
||||
[ >r dupd (add-history) r> pop swap set-model ] if ;
|
||||
[ 2drop ]
|
||||
[ >r dupd (add-history) r> pop swap set-model ] if-empty ;
|
||||
|
||||
: go-back ( history -- )
|
||||
dup [ forward>> ] [ back>> ] bi go-back/forward ;
|
||||
|
|
|
@ -38,13 +38,13 @@ IN: prettyprint
|
|||
[ write-in nl ] when* ;
|
||||
|
||||
: use. ( seq -- )
|
||||
dup empty? [ drop ] [
|
||||
[
|
||||
natural-sort [
|
||||
\ USING: pprint-word
|
||||
[ pprint-vocab ] each
|
||||
\ ; pprint-word
|
||||
] with-pprint nl
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: vocabs. ( in use -- )
|
||||
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
|
||||
|
@ -98,7 +98,7 @@ SYMBOL: ->
|
|||
"word-style" set-word-prop
|
||||
|
||||
: remove-step-into ( word -- )
|
||||
building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ;
|
||||
building get [ nip pop wrapped>> ] unless-empty , ;
|
||||
|
||||
: (remove-breakpoints) ( quot -- newquot )
|
||||
[
|
||||
|
|
|
@ -34,14 +34,12 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
|
|||
] keep head ;
|
||||
|
||||
: random ( seq -- elt )
|
||||
dup empty? [
|
||||
drop f
|
||||
] [
|
||||
[ f ] [
|
||||
[
|
||||
length dup log2 7 + 8 /i
|
||||
random-bytes byte-array>bignum swap mod
|
||||
] keep nth
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: delete-random ( seq -- elt )
|
||||
[ length random ] keep [ nth ] 2keep delete-nth ;
|
||||
|
|
|
@ -11,9 +11,9 @@ IN: stack-checker.backend
|
|||
: push-d ( obj -- ) meta-d get push ;
|
||||
|
||||
: pop-d ( -- obj )
|
||||
meta-d get dup empty? [
|
||||
drop <value> dup 1array #introduce, d-in inc
|
||||
] [ pop ] if ;
|
||||
meta-d get [
|
||||
<value> dup 1array #introduce, d-in inc
|
||||
] [ pop ] if-empty ;
|
||||
|
||||
: peek-d ( -- obj ) pop-d dup push-d ;
|
||||
|
||||
|
@ -40,7 +40,9 @@ IN: stack-checker.backend
|
|||
: output-r ( seq -- ) meta-r get push-all ;
|
||||
|
||||
: pop-literal ( -- rstate obj )
|
||||
pop-d [ 1array #drop, ] [ literal [ recursion>> ] [ value>> ] bi ] bi ;
|
||||
pop-d
|
||||
[ 1array #drop, ]
|
||||
[ literal [ recursion>> ] [ value>> ] bi ] bi ;
|
||||
|
||||
GENERIC: apply-object ( obj -- )
|
||||
|
||||
|
|
|
@ -31,10 +31,10 @@ SYMBOL: +bottom+
|
|||
|
||||
: unify-values ( values -- phi-out )
|
||||
remove-bottom
|
||||
dup empty? [ drop <value> ] [
|
||||
[ <value> ] [
|
||||
[ known ] map dup all-eq?
|
||||
[ first make-known ] [ drop <value> ] if
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: phi-outputs ( phi-in -- stack )
|
||||
flip [ unify-values ] map ;
|
||||
|
@ -42,12 +42,12 @@ SYMBOL: +bottom+
|
|||
SYMBOL: quotations
|
||||
|
||||
: unify-branches ( ins stacks -- in phi-in phi-out )
|
||||
zip dup empty? [ drop 0 { } { } ] [
|
||||
zip [ 0 { } { } ] [
|
||||
[ keys supremum ] [ ] [ balanced? ] tri
|
||||
[ dupd phi-inputs dup phi-outputs ]
|
||||
[ quotations get unbalanced-branches-error ]
|
||||
if
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: branch-variable ( seq symbol -- seq )
|
||||
'[ , _ at ] map ;
|
||||
|
|
|
@ -26,8 +26,8 @@ M: inference-error error-help error>> error-help ;
|
|||
|
||||
M: inference-error error.
|
||||
[
|
||||
rstate>> dup empty?
|
||||
[ drop ] [ "Nesting:" print stack. ] if
|
||||
rstate>>
|
||||
[ "Nesting:" print stack. ] unless-empty
|
||||
] [ error>> error. ] bi ;
|
||||
|
||||
TUPLE: literal-expected ;
|
||||
|
|
|
@ -69,15 +69,15 @@ IN: stack-checker.transforms
|
|||
\ cond [ cond>quot ] 1 define-transform
|
||||
|
||||
\ case [
|
||||
dup empty? [
|
||||
drop [ no-case ]
|
||||
[
|
||||
[ no-case ]
|
||||
] [
|
||||
dup peek quotation? [
|
||||
dup peek swap but-last
|
||||
] [
|
||||
[ no-case ] swap
|
||||
] if case>quot
|
||||
] if
|
||||
] if-empty
|
||||
] 1 define-transform
|
||||
|
||||
\ cleave [ cleave>quot ] 1 define-transform
|
||||
|
|
|
@ -73,7 +73,7 @@ SYMBOL: deploy-image
|
|||
: deploy-config ( vocab -- assoc )
|
||||
dup default-config swap
|
||||
dup deploy-config-path vocab-file-contents
|
||||
parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
|
||||
parse-fresh [ first assoc-union ] unless-empty ;
|
||||
|
||||
: set-deploy-config ( assoc vocab -- )
|
||||
>r unparse-use string-lines r>
|
||||
|
|
|
@ -67,8 +67,7 @@ SYMBOL: this-test
|
|||
: test-failures. ( assoc -- )
|
||||
[
|
||||
nl
|
||||
dup empty? [
|
||||
drop
|
||||
[
|
||||
"==== ALL TESTS PASSED" print
|
||||
] [
|
||||
"==== FAILING TESTS:" print
|
||||
|
@ -76,16 +75,16 @@ SYMBOL: this-test
|
|||
swap vocab-heading.
|
||||
[ failure. nl ] each
|
||||
] assoc-each
|
||||
] if
|
||||
] if-empty
|
||||
] [
|
||||
"==== NOTHING TO TEST" print
|
||||
] if* ;
|
||||
|
||||
: run-tests ( prefix -- failures )
|
||||
child-vocabs dup empty? [ drop f ] [
|
||||
child-vocabs [ f ] [
|
||||
[ dup run-test ] { } map>assoc
|
||||
[ second empty? not ] filter
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: test ( prefix -- )
|
||||
run-tests test-failures. ;
|
||||
|
|
|
@ -36,14 +36,14 @@ IN: tools.vocabs.browser
|
|||
|
||||
: vocabs. ( assoc -- )
|
||||
[
|
||||
dup empty? [
|
||||
2drop
|
||||
[
|
||||
drop
|
||||
] [
|
||||
swap root-heading.
|
||||
standard-table-style [
|
||||
vocab-headings. [ vocab. ] each
|
||||
] ($grid)
|
||||
] if
|
||||
] if-empty
|
||||
] assoc-each ;
|
||||
|
||||
: describe-summary ( vocab -- )
|
||||
|
@ -98,10 +98,10 @@ C: <vocab-author> vocab-author
|
|||
] when* ;
|
||||
|
||||
: describe-words ( vocab -- )
|
||||
words dup empty? [
|
||||
words [
|
||||
"Words" $heading
|
||||
dup natural-sort $links
|
||||
] unless drop ;
|
||||
natural-sort $links
|
||||
] unless-empty ;
|
||||
|
||||
: vocab-xref ( vocab quot -- vocabs )
|
||||
>r dup vocab-name swap words [ generic? not ] filter r> map
|
||||
|
@ -113,16 +113,16 @@ C: <vocab-author> vocab-author
|
|||
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
|
||||
|
||||
: describe-uses ( vocab -- )
|
||||
vocab-uses dup empty? [
|
||||
vocab-uses [
|
||||
"Uses" $heading
|
||||
dup $vocab-links
|
||||
] unless drop ;
|
||||
$vocab-links
|
||||
] unless-empty ;
|
||||
|
||||
: describe-usage ( vocab -- )
|
||||
vocab-usage dup empty? [
|
||||
vocab-usage [
|
||||
"Used by" $heading
|
||||
dup $vocab-links
|
||||
] unless drop ;
|
||||
$vocab-links
|
||||
] unless-empty ;
|
||||
|
||||
: $describe-vocab ( element -- )
|
||||
first
|
||||
|
|
|
@ -165,11 +165,11 @@ MEMO: vocab-file-contents ( vocab name -- seq )
|
|||
|
||||
: vocab-summary ( vocab -- summary )
|
||||
dup dup vocab-summary-path vocab-file-contents
|
||||
dup empty? [
|
||||
drop vocab-name " vocabulary" append
|
||||
[
|
||||
vocab-name " vocabulary" append
|
||||
] [
|
||||
nip first
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
M: vocab summary
|
||||
[
|
||||
|
@ -212,11 +212,9 @@ M: vocab-link summary vocab-summary ;
|
|||
|
||||
: (all-child-vocabs) ( root name -- vocabs )
|
||||
[ vocab-dir append-path subdirs ] keep
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
[
|
||||
swap [ "." swap 3append ] with map
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: vocabs-in-dir ( root name -- )
|
||||
dupd (all-child-vocabs) [
|
||||
|
|
|
@ -197,7 +197,7 @@ SYMBOL: +stopped+
|
|||
: step-back-msg ( continuation -- continuation' )
|
||||
walker-history tget
|
||||
[ pop* ]
|
||||
[ dup empty? [ drop ] [ nip pop ] if ] bi ;
|
||||
[ [ nip pop ] unless-empty ] bi ;
|
||||
|
||||
: walker-suspended ( continuation -- continuation' )
|
||||
+suspended+ set-status
|
||||
|
|
|
@ -108,7 +108,7 @@ SYMBOL: double-click-timeout
|
|||
|
||||
: drag-gesture ( -- )
|
||||
hand-buttons get-global
|
||||
dup empty? [ drop ] [ first <drag> button-gesture ] if ;
|
||||
[ first <drag> button-gesture ] unless-empty ;
|
||||
|
||||
SYMBOL: drag-timer
|
||||
|
||||
|
@ -170,7 +170,7 @@ SYMBOL: drag-timer
|
|||
|
||||
: modifier ( mod modifiers -- seq )
|
||||
[ second swap bitand 0 > ] with filter
|
||||
0 <column> prune dup empty? [ drop f ] [ >array ] if ;
|
||||
0 <column> prune [ f ] [ >array ] if-empty ;
|
||||
|
||||
: drag-loc ( -- loc )
|
||||
hand-loc get-global hand-click-loc get-global v- ;
|
||||
|
|
|
@ -72,11 +72,9 @@ M: listener-operation invoke-command ( target command -- )
|
|||
evaluate-input ;
|
||||
|
||||
: listener-run-files ( seq -- )
|
||||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
[
|
||||
[ [ run-file ] each ] curry call-listener
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: com-end ( listener -- )
|
||||
input>> interactor-eof ;
|
||||
|
|
|
@ -80,10 +80,10 @@ VALUE: grapheme-table
|
|||
nip swap length or 1+ ;
|
||||
|
||||
: (>graphemes) ( str -- )
|
||||
dup empty? [ drop ] [
|
||||
[
|
||||
dup first-grapheme cut-slice
|
||||
swap , (>graphemes)
|
||||
] if ;
|
||||
] unless-empty ;
|
||||
|
||||
: >graphemes ( str -- graphemes )
|
||||
[ (>graphemes) ] { } make ;
|
||||
|
|
|
@ -100,7 +100,7 @@ unless
|
|||
"windows.com.wrapper.callbacks" create ;
|
||||
|
||||
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
|
||||
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
|
||||
[ [ drop [ ] ] [ swap 1- '[ , , ndip ] ] if-empty ]
|
||||
dip compose ;
|
||||
|
||||
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
|
||||
|
|
|
@ -164,7 +164,7 @@ SYMBOL: ns-stack
|
|||
T{ name f "" "encoding" f }
|
||||
T{ name f "" "standalone" f }
|
||||
} diff
|
||||
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
|
||||
[ <extra-attrs> throw ] unless-empty ;
|
||||
|
||||
: good-version ( version -- version )
|
||||
dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
|
||||
|
|
|
@ -34,7 +34,7 @@ SYMBOL: indenter
|
|||
: ?filter-children ( children -- no-whitespace )
|
||||
xml-pprint? get [
|
||||
[ dup string? [ trim-whitespace ] when ] map
|
||||
[ dup empty? swap string? and not ] filter
|
||||
[ [ empty? ] [ string? ] bi and not ] filter
|
||||
] when ;
|
||||
|
||||
: print-name ( name -- )
|
||||
|
|
Loading…
Reference in New Issue