bring back ( x: type y: type -- ) stack effect syntax, and automatically hint words based on types in their declared effect

basis/hints/hints.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions fry generic generic.single
+combinators definitions effects fry generic generic.single
 generic.standard hashtables io.binary io.streams.string kernel
 kernel.private math math.parser namespaces parser sbufs
 sequences splitting splitting.private strings vectors words ;
@@ -19,6 +19,14 @@ M: class specializer-declaration ;
 
 M: object specializer-declaration class ;
 
+: specialized? ( types -- ? )
+    [ object = ] all? not ;
+
+: specializer ( word -- specializer )
+    [ "specializer" word-prop ]
+    [ stack-effect effect-in-types ] bi
+    dup specialized? [ suffix ] [ drop ] if ;
+
 : make-specializer ( specs -- quot )
     dup length <reversed>
     [ (picker) 2array ] 2map
@@ -49,7 +57,7 @@ t specialize-method? set-global
 
 : specialize-method ( quot method -- quot' )
     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
-    [ "method-generic" word-prop "specializer" word-prop ] bi
+    [ "method-generic" word-prop specializer ] bi
     [ specialize-quot ] when* ;
 
 : standard-method? ( method -- ? )
@@ -61,7 +69,7 @@ t specialize-method? set-global
     [ def>> ] keep
     dup generic? [ drop ] [
         [ dup standard-method? [ specialize-method ] [ drop ] if ]
-        [ "specializer" word-prop [ specialize-quot ] when* ]
+        [ specializer [ specialize-quot ] when* ]
         bi
     ] if ;
 

core/effects/effects-tests.factor

@@ -1,4 +1,5 @@
-USING: effects tools.test prettyprint accessors sequences ;
+USING: effects kernel tools.test prettyprint accessors
+quotations sequences ;
 IN: effects.tests
 
 [ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
@@ -23,3 +24,6 @@ IN: effects.tests
 [ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
 [ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
 [ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
+
+[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
+[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test

core/effects/effects.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.parser math.order namespaces make sequences strings
-words assocs combinators accessors arrays ;
+words assocs combinators accessors arrays quotations ;
 IN: effects
 
 TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
@@ -53,6 +53,13 @@ M: effect effect>string ( effect -- string )
         ")" %
     ] "" make ;
 
+GENERIC: effect>type ( obj -- type )
+M: object effect>type drop object ;
+M: word effect>type ;
+! attempting to specialize on callable breaks compiling
+! M: effect effect>type drop callable ;
+M: pair effect>type second effect>type ;
+
 GENERIC: stack-effect ( word -- effect/f )
 
 M: word stack-effect "declared-effect" word-prop ;
@@ -87,3 +94,8 @@ M: effect clone
         [ [ [ "obj" ] replicate ] bi@ ] dip
         effect boa
     ] if ; inline
+
+: effect-in-types ( effect -- input-types )
+    in>> [ effect>type ] map ;
+: effect-out-types ( effect -- input-types )
+    out>> [ effect>type ] map ;

core/effects/parser/parser.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lexer sets sequences kernel splitting effects
-combinators arrays ;
+combinators arrays vocabs.parser classes ;
 IN: effects.parser
 
 DEFER: parse-effect
@@ -13,10 +13,11 @@ ERROR: bad-effect ;
         dup { f "(" "((" } member? [ bad-effect ] [
             ":" ?tail [
                 scan {
-                    { "(" [ ")" parse-effect ] }
-                    { f [ ")" unexpected-eof ] }
+                    { [ dup "(" = ] [ drop ")" parse-effect ] }
+                    { [ dup search class? ] [ search ] }
+                    { [ dup f = ] [ ")" unexpected-eof ] }
                     [ bad-effect ]
-                } case 2array
+                } cond 2array
             ] when
         ] if
     ] if ;