combinators.extras: adding a variant to cond.

diff --git a/extra/combinators/extras/extras-tests.factor b/extra/combinators/extras/extras-tests.factor
index 3a34f4f7d0eab4b6d9fa12570891b111d3df66da..39a3504698046f35a9c9ad4726b703424fb815df 100644 (file)
--- a/extra/combinators/extras/extras-tests.factor
+++ b/extra/combinators/extras/extras-tests.factor
@@ -38,3 +38,26 @@ IN: combinators.extras.tests
 { t } [ "resource:" [ exists? ] ?1arg >boolean ] unit-test
 { f } [ f [ 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

diff --git a/extra/combinators/extras/extras.factor b/extra/combinators/extras/extras.factor
index 4cb162e439d94f89d88fbb241648df6a20d05fe1..274c0e860b4abf6d7e7a5b05b251f2dd20c7f416 100644 (file)
--- a/extra/combinators/extras/extras.factor
+++ b/extra/combinators/extras/extras.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2013 Doug Coleman, John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators combinators.smart fry generalizations
-kernel macros math quotations sequences locals math.order
-sequences.generalizations sequences.private system ;
+USING: arrays assocs combinators combinators.smart fry
+generalizations kernel macros math quotations sequences locals
+math.order sequences.generalizations sequences.private
+stack-checker.transforms system words ;
 IN: combinators.extras
 
 : once ( quot -- ) call ; inline
@@ -88,3 +89,20 @@ MACRO:: n-falsify ( n -- quot )
 
 : ?2arg ( obj1 obj2 quot: ( obj1 obj2 -- ? ) -- obj1/f obj2/f )
     [ ?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* ;