-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 ;
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 ;
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 )
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 + ;
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 ;
: 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 ]
:: 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 ;