steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

combinators.extras: adding a variant to cond.

char-rename
John Benediktsson 2017-02-21 14:51:30 -08:00
parent b00aef99e2
commit 890be49074
2 changed files with 44 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
extra/combinators/extras/extras-tests.factor
View File

@ -38,3 +38,26 @@ IN: combinators.extras.tests
{ t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test { t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
{ f } [ f [ exists? ] ?1arg ] unit-test { f } [ f [ exists? ] ?1arg ] unit-test
{ f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test { f } [ "/homeasdfasdf123123" [ exists? ] ?1arg ] unit-test
{ "hi " "there" } [
"hi there" {
{ [ "there" over start ] [ cut ] }
[ f ]
} cond*
] unit-test
{ "hi " "there" } [
"hi there" {
{ [ "foo" over start ] [ head f ] }
{ [ "there" over start ] [ cut ] }
[ f ]
} cond*
] unit-test
{ "hi there" f } [
"hi there" {
{ [ "foo" over start ] [ head f ] }
{ [ "bar" over start ] [ cut ] }
[ f ]
} cond*
] unit-test

24
extra/combinators/extras/extras.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2013 Doug Coleman, John Benediktsson. ! Copyright (C) 2013 Doug Coleman, John Benediktsson.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators combinators.smart fry generalizations USING: arrays assocs combinators combinators.smart fry
kernel macros math quotations sequences locals math.order generalizations kernel macros math quotations sequences locals
sequences.generalizations sequences.private system ; math.order sequences.generalizations sequences.private
stack-checker.transforms system words ;
IN: combinators.extras IN: combinators.extras
: once ( quot -- ) call ; inline : once ( quot -- ) call ; inline
@ -88,3 +89,20 @@ MACRO:: n-falsify ( n -- quot )
: ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f ) : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
[ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline [ ?2res ] 3keep drop '[ _ _ ] [ f f ] if ; inline
<<
: alist>quot* ( default assoc -- quot )
[ rot \ if* 3array append [ ] like ] assoc-each ;
: cond*>quot ( assoc -- quot )
[ dup pair? [ [ drop ] prepend [ t ] swap 2array ] unless ] map
reverse! [ no-cond ] swap alist>quot* ;
DEFER: cond*
\ cond* [ cond*>quot ] 1 define-transform
\ cond* t "no-compile" set-word-prop
>>
: cond* ( assoc -- )
[ dup callable? [ drop t ] [ first call ] if ] map-find
[ dup callable? [ nip call ] [ second call ] if ]
[ no-cond ] if* ;