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

diff --git a/basis/typed/prettyprint/prettyprint.factor b/basis/typed/prettyprint/prettyprint.factor
index 8a7ff5b7b2455594dad04de5a71ee78e50c2d45f..4bb8814e4cad00f26462966da331dc166d620108 100644 (file)
--- a/basis/typed/prettyprint/prettyprint.factor
+++ b/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 ;

diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor
index bca1136ee6bb57f44eefd378931a4d3526e5772e..70edcf2334c383fde7c868419b09f731312573d3 100644 (file)
--- a/basis/typed/typed-tests.factor
+++ b/basis/typed/typed-tests.factor
@@ -1,6 +1,6 @@
 USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
-compiler.tree.debugger prettyprint definitions compiler.units ;
+quotations tools.test typed words words.symbol combinators.short-circuit
+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-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
+[ { [ 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 + ;

diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor
index 50da7b1bad5e1386c45c563058ad97cb44837662..fe2ba417220650e9179f494e64005a6a8073092b 100644 (file)
--- a/basis/typed/typed.factor
+++ 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 ;