Fixing hook stack effects

core/generic/generic-tests.factor

@@ -123,17 +123,6 @@ M: integer wii drop 6 ;
 
 [ 3 ] [ T{ first-one } wii ] unit-test
 
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
 GENERIC: tag-and-f ( x -- x x )
 
 M: fixnum tag-and-f 1 ;

core/generic/generic.factor

@@ -38,7 +38,10 @@ GENERIC: effective-method ( ... generic -- method )
 : next-method ( class generic -- class/f )
     [ next-method-class ] keep method ;
 
-GENERIC: next-method-quot ( class generic -- quot )
+GENERIC: next-method-quot* ( class generic -- quot )
+
+: next-method-quot ( class generic -- quot )
+    dup "combination" word-prop next-method-quot* ;
 
 : (call-next-method) ( class generic -- )
     next-method-quot call ;

core/generic/standard/engines/engines.factor

@@ -47,3 +47,5 @@ SYMBOL: (dispatch#)
     } case ;
 
 : picker ( -- quot ) \ (dispatch#) get (picker) ;
+
+GENERIC: extra-values ( method generic -- n )

core/generic/standard/engines/tuple/tuple.factor

@@ -66,7 +66,9 @@ PREDICATE: tuple-dispatch-engine-word < word
     "tuple-dispatch-engine" word-prop ;
 
 M: tuple-dispatch-engine-word stack-effect
-    "tuple-dispatch-generic" word-prop stack-effect ;
+    "tuple-dispatch-generic" word-prop
+    [ extra-values ] [ stack-effect clone ] bi
+    [ length + ] change-in ;
 
 M: tuple-dispatch-engine-word crossref?
     drop t ;

core/generic/standard/standard-tests.factor

@@ -1,7 +1,8 @@
 IN: generic.standard.tests
 USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser namespaces ;
+words float-arrays byte-arrays bit-arrays parser namespaces
+quotations inference vectors growable ;
 
 GENERIC: lo-tag-test
 
@@ -194,7 +195,7 @@ M: ceo salary
 [ 102000 ] [ executive construct-boa salary ] unit-test
 
 [ ceo construct-boa salary ]
-[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
 
 [ intern construct-boa salary ]
 [ T{ no-next-method f intern salary } = ] must-fail-with
@@ -233,3 +234,37 @@ M: c funky* "c" , call-next-method ;
     T{ a } funky
     { { "a" "x" "z" } { "a" "y" "z" } } member?
 ] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: my-tuple-hook my-var ( -- x )
+
+M: sequence my-tuple-hook my-hook ;
+
+[ f ] [
+    \ my-tuple-hook [ "engines" word-prop ] keep prefix
+    [ 1quotation infer ] map all-equal?
+] unit-test
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+    V{ } my-var [ call-next-hooker ] with-variable
+] unit-test

core/generic/standard/standard.factor

@@ -67,7 +67,9 @@ ERROR: no-method object generic ;
         drop generic get "default-method" word-prop 1quotation
     ] unless ;
 
-GENERIC: mangle-method ( method generic -- quot )
+: mangle-method ( method generic -- quot )
+    [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
+    prepend [ ] like ;
 
 : single-combination ( word -- quot )
     [
@@ -91,6 +93,23 @@ GENERIC: mangle-method ( method generic -- quot )
         } cleave
     ] with-scope ;
 
+ERROR: inconsistent-next-method class generic ;
+
+ERROR: no-next-method class generic ;
+
+: single-next-method-quot ( class generic -- quot )
+    [
+        [ drop [ instance? ] curry % ]
+        [
+            2dup next-method
+            [ 2nip 1quotation ]
+            [ [ no-next-method ] 2curry ] if* ,
+        ]
+        [ [ inconsistent-next-method ] 2curry , ]
+        2tri
+        \ if ,
+    ] [ ] make ;
+
 TUPLE: standard-combination # ;
 
 C: <standard-combination> standard-combination
@@ -107,8 +126,7 @@ PREDICATE: simple-generic < standard-generic
 : with-standard ( combination quot -- quot' )
     >r #>> (dispatch#) r> with-variable ; inline
 
-M: standard-generic mangle-method
-    drop 1quotation ;
+M: standard-generic extra-values drop 0 ;
 
 M: standard-combination make-default-method
     [ empty-method ] with-standard ;
@@ -118,30 +136,15 @@ M: standard-combination perform-combination
 
 M: standard-combination dispatch# #>> ;
 
+M: standard-combination next-method-quot*
+    [
+        single-next-method-quot picker prepend
+    ] with-standard ;
+
 M: standard-generic effective-method
     [ dispatch# (picker) call ] keep
     [ order [ instance? ] with find-last nip ] keep method ;
 
-ERROR: inconsistent-next-method object class generic ;
-
-ERROR: no-next-method class generic ;
-
-M: standard-generic next-method-quot
-    [
-        [
-            [ [ instance? ] curry ]
-            [ dispatch# (picker) ] bi* prepend %
-        ]
-        [
-            2dup next-method
-            [ 2nip 1quotation ]
-            [ [ no-next-method ] 2curry ] if* ,
-        ]
-        [ [ inconsistent-next-method ] 2curry , ]
-        2tri
-        \ if ,
-    ] [ ] make ;
-
 TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
@@ -156,8 +159,7 @@ PREDICATE: hook-generic < generic
 
 M: hook-combination dispatch# drop 0 ;
 
-M: hook-generic mangle-method
-    drop 1quotation [ drop ] prepend ;
+M: hook-generic extra-values drop 1 ;
 
 M: hook-combination make-default-method
     [ error-method ] with-hook ;
@@ -165,6 +167,9 @@ M: hook-combination make-default-method
 M: hook-combination perform-combination
     [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
 
+M: hook-combination next-method-quot*
+    [ single-next-method-quot ] with-hook ;
+
 M: simple-generic definer drop \ GENERIC: f ;
 
 M: standard-generic definer drop \ GENERIC# f ;

core/inference/backend/backend.factor

@@ -36,6 +36,8 @@ TUPLE: inference-error error type rstate ;
 
 M: inference-error compiler-error-type type>> ;
 
+M: inference-error error-help error>> error-help ;
+
 : (inference-error) ( ... class type -- * )
     >r construct-boa r>
     recursive-state get
@@ -359,7 +361,7 @@ TUPLE: effect-error word effect ;
     \ effect-error inference-error ;
 
 : check-effect ( word effect -- )
-    dup pick "declared-effect" word-prop effect<=
+    dup pick stack-effect effect<=
     [ 2drop ] [ effect-error ] if ;
 
 : finish-word ( word -- )