diff --git a/basis/typed/prettyprint/prettyprint.factor b/basis/typed/prettyprint/prettyprint.factor index 8a7ff5b7b2..4bb8814e4c 100644 --- 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 bca1136ee6..70edcf2334 100644 --- 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 50da7b1bad..fe2ba41722 100644 --- 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 ;