combinators.extras: adding cond-case.

extra/combinators/extras/extras-docs.factor

@@ -0,0 +1,24 @@
+USING: combinators help.markup help.syntax ;
+
+IN: combinators.extras
+
+HELP: cond-case
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
+{ $description
+    "Similar to " { $link case } ", this evaluates an " { $snippet "obj" } " according to the first quotation in each pair.  If any quotation returns true, calls the second quotation without " { $snippet "obj" } " on the stack."
+    $nl
+    "If there is no quotation that returns true, the default case is taken.  If the last element of " { $snippet "assoc" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack.  Otherwise, a " { $link no-cond } " error is raised."
+}
+{ $examples
+    { $example
+        "USING: combinators.extras io kernel math ;"
+        "0 {"
+        "    { [ 0 > ] [ \"positive\" ] }"
+        "    { [ 0 < ] [ \"negative\" ] }"
+        "    [ drop \"zero\" ]"
+        "} cond-case print"
+        "zero"
+    }
+} ;
+
+

extra/combinators/extras/extras-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2013 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.extras sequences ;
+USING: math tools.test combinators.extras sequences ;
 IN: combinators.extras.tests
 
 { "a b" }
@@ -11,3 +11,13 @@ IN: combinators.extras.tests
 
 { "a b c d" }
 [ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
+
+[ { "negative" 0 "positive" } ] [
+    { -1 0 1 } [
+        {
+           { [ 0 > ] [ "positive" ] }
+           { [ 0 < ] [ "negative" ] }
+           [ ]
+        } cond-case
+    ] map
+] unit-test

extra/combinators/extras/extras.factor

@@ -1,8 +1,16 @@
-! Copyright (C) 2013 Doug Coleman.
+! Copyright (C) 2013 Doug Coleman, John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: arrays combinators kernel macros quotations sequences ;
 IN: combinators.extras
 
 : once ( quot -- ) call ; inline
 : twice ( quot -- ) dup [ call ] dip call ; inline
 : thrice ( quot -- ) dup dup [ call ] 2dip [ call ] dip call ; inline
+
+MACRO: cond-case ( assoc -- )
+    [
+        dup callable? not [
+            [ first [ dup ] prepose ]
+            [ second [ drop ] prepose ] bi 2array
+        ] when
+    ] map [ cond ] curry ;