steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2010-06-14 14:23:55 -07:00
parent 173880168a
commit 6ce01d0b0d
3 changed files with 33 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
basis/typed/prettyprint/prettyprint.factor
View File

@ -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 ;

13
basis/typed/typed-tests.factor
View File

@ -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 + ;

7
basis/typed/typed.factor
View File

@ -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 ;