Fixing error reporting
parent
2cebf7e9e5
commit
a82794a719
extra/multi-methods
|
@ -117,9 +117,18 @@ SYMBOL: total
|
|||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if ;
|
||||
|
||||
: argument-count ( methods -- n )
|
||||
keys 0 [ length max ] reduce ;
|
||||
|
||||
ERROR: no-method arguments generic ;
|
||||
|
||||
: make-default-method ( methods generic -- quot )
|
||||
>r argument-count r> [ >r narray r> no-method ] 2curry ;
|
||||
|
||||
: multi-dispatch-quot ( methods generic -- quot )
|
||||
"default-multi-method" word-prop 1quotation swap
|
||||
[ >r multi-predicate r> ] assoc-map reverse alist>quot ;
|
||||
[ make-default-method ]
|
||||
[ drop [ >r multi-predicate r> ] assoc-map reverse ]
|
||||
2bi alist>quot ;
|
||||
|
||||
! Generic words
|
||||
PREDICATE: generic < word
|
||||
|
@ -178,11 +187,6 @@ M: method-body crossref?
|
|||
drop [ <method> dup ] 2keep reveal-method
|
||||
] if ;
|
||||
|
||||
TUPLE: no-method arguments generic ;
|
||||
|
||||
: no-method ( argument-count generic -- * )
|
||||
>r narray r> \ no-method construct-boa throw ; inline
|
||||
|
||||
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
|
||||
|
||||
M: no-method error.
|
||||
|
@ -196,18 +200,8 @@ M: no-method error.
|
|||
dup arguments>> [ class ] map niceify-method .
|
||||
nl
|
||||
"Available methods: " print
|
||||
generic>> methods keys
|
||||
[ niceify-method ] map stack. ;
|
||||
|
||||
: make-default-method ( generic -- quot )
|
||||
[ 0 swap no-method ] curry ;
|
||||
|
||||
: <default-method> ( generic -- method )
|
||||
[ { } swap <method> ] keep
|
||||
[ drop ] [ make-default-method define ] 2bi ;
|
||||
|
||||
: define-default-method ( generic -- )
|
||||
dup <default-method> "default-multi-method" set-word-prop ;
|
||||
generic>> methods canonicalize-specializers drop sort-methods
|
||||
keys [ niceify-method ] map stack. ;
|
||||
|
||||
: forget-method ( specializer generic -- )
|
||||
[ delete-at ] with-methods ;
|
||||
|
@ -221,9 +215,8 @@ M: no-method error.
|
|||
drop
|
||||
] [
|
||||
[ H{ } clone "multi-methods" set-word-prop ]
|
||||
[ define-default-method ]
|
||||
[ update-generic ]
|
||||
tri
|
||||
bi
|
||||
] if ;
|
||||
|
||||
! Syntax
|
||||
|
|
|
@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ;
|
|||
|
||||
\ GENERIC: must-infer
|
||||
\ create-method-in must-infer
|
||||
\ define-default-method must-infer
|
||||
|
||||
DEFER: fake
|
||||
\ fake H{ } clone "multi-methods" set-word-prop
|
||||
|
@ -17,11 +16,9 @@ DEFER: fake
|
|||
[ t ] [ { } \ fake <method> method-body? ] unit-test
|
||||
|
||||
[
|
||||
[ ] [ \ fake define-default-method ] unit-test
|
||||
|
||||
[ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
|
||||
|
||||
[ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
|
||||
[ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
|
||||
|
||||
[ t ] [ \ fake make-generic quotation? ] unit-test
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
IN: multi-methods.tests
|
||||
USING: multi-methods tools.test math sequences namespaces system
|
||||
kernel strings definitions prettyprint debugger arrays
|
||||
hashtables continuations classes assocs ;
|
||||
hashtables continuations classes assocs accessors ;
|
||||
|
||||
GENERIC: first-test
|
||||
|
||||
|
@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ;
|
|||
[ { } 3 play ] must-fail
|
||||
[ t ] [ error get no-method? ] unit-test
|
||||
[ ] [ error get error. ] unit-test
|
||||
[ { { } 3 } ] [ error get arguments>> ] unit-test
|
||||
[ t ] [ paper scissors play ] unit-test
|
||||
[ f ] [ scissors paper play ] unit-test
|
||||
|
||||
|
@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ;
|
|||
5.0 some-var set
|
||||
[ 0 ] [ H{ } hook-test ] unit-test
|
||||
|
||||
"error" some-var set
|
||||
[ H{ } hook-test ] must-fail
|
||||
[ t ] [ error get no-method? ] unit-test
|
||||
[ { H{ } "error" } ] [ error get arguments>> ] unit-test
|
||||
|
||||
MIXIN: busted
|
||||
|
||||
TUPLE: busted-1 ;
|
||||
|
|
Loading…
Reference in New Issue