typed: include value that raised the error in type-mismatch-errors

basis/typed/prettyprint/prettyprint.factor

@@ -1,4 +1,5 @@
-USING: definitions kernel locals.definitions see see.private typed words ;
+USING: definitions kernel locals.definitions see see.private typed words
+summary make accessors classes ;
 IN: typed.prettyprint
 
 PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
@@ -9,3 +10,24 @@ M: typed-lambda-word definer drop \ TYPED:: \ ; ;
 M: typed-word definition "typed-def" word-prop ;
 M: typed-word declarations. "typed-word" word-prop declarations. ;
 
+M: input-mismatch-error summary
+    [
+        "Typed word “" %
+        dup word>> name>> %
+        "” expected input value of type " %
+        dup expected-type>> name>> %
+        " but got " %
+        dup value>> class name>> %
+        drop
+    ] "" make ;
+
+M: output-mismatch-error summary
+    [
+        "Typed word “" %
+        dup word>> name>> %
+        "” expected to output value of type " %
+        dup expected-type>> name>> %
+        " but gave " %
+        dup value>> class name>> %
+        drop
+    ] "" make ;

basis/typed/typed-tests.factor

@@ -1,6 +1,6 @@
 USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
+quotations tools.test typed words words.symbol combinators.short-circuit
-compiler.tree.debugger prettyprint definitions compiler.units ;
+compiler.tree.debugger prettyprint definitions compiler.units sequences ;
 IN: typed.tests
 
 TYPED: f+ ( a: float b: float -- c: float )
@@ -24,14 +24,17 @@ TYPED: dee ( x: tweedle-dee -- y )
 TYPED: dum ( x: tweedle-dum -- y )
     drop \ tweedle-dum ;
 
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
 
+[ \ tweedle-dee new dum ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
 
 TYPED: dumdum ( x -- y: tweedle-dum )
     drop \ tweedle-dee new ;
 
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+[ f dumdum ]
+[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
 
 TYPED:: f+locals ( a: float b: float -- c: float )
     a b + ;

basis/typed/typed.factor

@@ -7,7 +7,7 @@ locals.parser macros stack-checker.dependencies ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: typed
 
-ERROR: type-mismatch-error word expected-types ;
+ERROR: type-mismatch-error value expected-type word expected-types ;
 ERROR: input-mismatch-error < type-mismatch-error ;
 ERROR: output-mismatch-error < type-mismatch-error ;
 
@@ -28,9 +28,6 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 : typed-stack-effect? ( effect -- ? )
     [ object = ] all? not ;
 
-: input-mismatch-quot ( word types -- quot )
-    [ input-mismatch-error ] 2curry ;
-
 : depends-on-unboxing ( class -- )
     [ dup tuple-layout depends-on-tuple-layout ]
     [ depends-on-final ]
@@ -47,7 +44,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 
 :: unboxer ( error-quot word types type -- quot )
     type "coercer" word-prop [ ] or
-    [ dup type instance? [ word types error-quot call ] unless ]
+    type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
     type (unboxer)
     compose compose ;