effects: fix bug reported by Joe where printing { f } { } <effect> kills the listener; simpler implementation of 'shuffle'; add compiler transform to 'shuffle' if effect is constant

basis/generalizations/generalizations.factor

@@ -2,7 +2,7 @@
 ! Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private math combinators
-macros quotations fry ;
+macros quotations fry stack-checker.transforms effects ;
 IN: generalizations
 
 <<
@@ -95,3 +95,11 @@ MACRO: nweave ( n -- )
     [ narray concat ] dip like ; inline
 
 : nappend ( n -- seq ) narray concat ; inline
+
+: nths-quot ( indices -- quot )
+    [ [ '[ _ swap nth ] ] map ] [ length ] bi
+    '[ _ cleave _ narray ] ;
+
+\ shuffle [
+    shuffle-mapping nths-quot
+] 1 define-transform

core/effects/effects-tests.factor

@@ -9,9 +9,13 @@ USING: effects tools.test prettyprint accessors sequences ;
 [ 2 ] [ (( a b -- c )) in>> length ] unit-test
 [ 1 ] [ (( a b -- c )) out>> length ] unit-test
 
-
+[ "(( object -- object ))" ] [ { f } { f } <effect> unparse ] unit-test
 [ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
 [ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
 [ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
 [ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
 [ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
+
+[ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
+[ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
+[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test

core/effects/effects.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.parser namespaces make sequences strings
 words assocs combinators accessors arrays ;
@@ -24,6 +24,7 @@ TUPLE: effect in out terminated? ;
 
 GENERIC: effect>string ( obj -- str )
 M: string effect>string ;
+M: object effect>string drop "object" ;
 M: word effect>string name>> ;
 M: integer effect>string number>string ;
 M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
@@ -45,8 +46,8 @@ M: effect effect>string ( effect -- string )
 GENERIC: stack-effect ( word -- effect/f )
 
 M: word stack-effect
-    { "declared-effect" "inferred-effect" }
-    swap props>> [ at ] curry map [ ] find nip ;
+    "inferred-effect" "declared-effect"
+    [ word-prop ] bi-curry@ bi or ;
 
 M: effect clone
     [ in>> clone ] [ out>> clone ] bi <effect> ;
@@ -57,11 +58,8 @@ M: effect clone
 : split-shuffle ( stack shuffle -- stack1 stack2 )
     in>> length cut* ;
 
-: load-shuffle ( stack shuffle -- )
-    in>> [ set ] 2each ;
-
-: shuffled-values ( shuffle -- values )
-    out>> [ get ] map ;
+: shuffle-mapping ( effect -- mapping )
+    [ out>> ] [ in>> ] bi [ index ] curry map ;
 
 : shuffle ( stack shuffle -- newstack )
-    [ [ load-shuffle ] keep shuffled-values ] with-scope ;
+    shuffle-mapping swap nths ;