typed: Teach typed about maybe: foo. Should maybe: foo satisfy unboxable-tuple-class? ?
							parent
							
								
									067f9830ef
								
							
						
					
					
						commit
						0bdd87dace
					
				| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
USING: definitions kernel locals.definitions see see.private typed words
 | 
			
		||||
summary make accessors classes ;
 | 
			
		||||
USING: definitions kernel locals.definitions see see.private typed
 | 
			
		||||
words summary make accessors classes prettyprint ;
 | 
			
		||||
IN: typed.prettyprint
 | 
			
		||||
 | 
			
		||||
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
 | 
			
		||||
| 
						 | 
				
			
			@ -15,7 +15,7 @@ M: input-mismatch-error summary
 | 
			
		|||
        "Typed word “" %
 | 
			
		||||
        dup word>> name>> %
 | 
			
		||||
        "” expected input value of type " %
 | 
			
		||||
        dup expected-type>> name>> %
 | 
			
		||||
        dup expected-type>> unparse %
 | 
			
		||||
        " but got " %
 | 
			
		||||
        dup value>> class-of name>> %
 | 
			
		||||
        drop
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -161,3 +161,9 @@ TYPED: forget-fail ( a: forget-class -- ) drop ;
 | 
			
		|||
[ ] [ [ \ forget-class forget ] with-compilation-unit ] unit-test
 | 
			
		||||
 | 
			
		||||
[ ] [ [ \ forget-fail forget ] with-compilation-unit ] unit-test
 | 
			
		||||
 | 
			
		||||
TYPED: typed-maybe ( x: maybe: integer -- ? ) >boolean ;
 | 
			
		||||
 | 
			
		||||
[ f ] [ f typed-maybe ] unit-test
 | 
			
		||||
[ t ] [ 30 typed-maybe ] unit-test
 | 
			
		||||
[ 30.0 typed-maybe ] [ input-mismatch-error? ] must-fail-with
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -3,7 +3,8 @@ USING: accessors arrays classes classes.tuple combinators
 | 
			
		|||
combinators.short-circuit definitions effects fry hints
 | 
			
		||||
math kernel kernel.private namespaces parser quotations
 | 
			
		||||
sequences slots words locals effects.parser
 | 
			
		||||
locals.parser macros stack-checker.dependencies ;
 | 
			
		||||
locals.parser macros stack-checker.dependencies
 | 
			
		||||
classes.union ;
 | 
			
		||||
FROM: classes.tuple.private => tuple-layout ;
 | 
			
		||||
IN: typed
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -18,6 +19,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 | 
			
		|||
 | 
			
		||||
: unboxable-tuple-class? ( type -- ? )
 | 
			
		||||
    {
 | 
			
		||||
        [ maybe? not ]
 | 
			
		||||
        [ all-slots empty? not ]
 | 
			
		||||
        [ immutable-tuple-class? ]
 | 
			
		||||
        [ final-class? ]
 | 
			
		||||
| 
						 | 
				
			
			@ -43,7 +45,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 | 
			
		|||
    ] [ drop [ ] ] if ;
 | 
			
		||||
 | 
			
		||||
:: unboxer ( error-quot word types type -- quot )
 | 
			
		||||
    type "coercer" word-prop [ ] or
 | 
			
		||||
    type word? [ type "coercer" word-prop ] [ f ] if [ ] or
 | 
			
		||||
    type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
 | 
			
		||||
    type (unboxer)
 | 
			
		||||
    compose compose ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue