diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index 92ddcc494a..7acf97a436 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -12,15 +12,3 @@ HELP: SINGLETON: } { $see-also POSTPONE: PREDICATE: } ; - -HELP: SINGLETONS: -{ $syntax "SINGLETONS: classes... ;" -} { $values - { "classes" "new singletons to define" } -} { $description - "Defines a new singleton for each class in the list." -} { $examples - { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" } -} { $see-also - POSTPONE: SINGLETON: -} ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor index 1698181ed3..da2a74f8d1 100644 --- a/extra/singleton/singleton-tests.factor +++ b/extra/singleton/singleton-tests.factor @@ -1,4 +1,4 @@ -USING: kernel singleton tools.test ; +USING: kernel singleton tools.test prettyprint io.streams.string ; IN: singleton.tests [ ] [ SINGLETON: bzzt ] unit-test @@ -7,3 +7,6 @@ IN: singleton.tests GENERIC: zammo ( obj -- ) [ ] [ M: bzzt zammo drop "yes!" ; ] unit-test [ "yes!" ] [ bzzt zammo ] unit-test +[ ] [ SINGLETON: omg ] unit-test +[ t ] [ omg singleton? ] unit-test +[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 9ec9f2f4a3..99319fdfdb 100755 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,16 +1,23 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes.predicate kernel namespaces parser quotations -sequences words ; +sequences words prettyprint prettyprint.backend prettyprint.sections +compiler.units classes ; +USE: tools.walker IN: singleton +PREDICATE: singleton < predicate-class + [ "predicate-definition" word-prop ] + [ [ eq? ] curry ] bi sequence= ; + : define-singleton ( token -- ) create-class-in - \ word + dup save-location + \ singleton over [ eq? ] curry define-predicate-class ; : SINGLETON: scan define-singleton ; parsing -: SINGLETONS: - ";" parse-tokens [ define-singleton ] each ; parsing +M: singleton see-class* ( class -- ) +