classes: Make methods dispatch on maybes. Fix a couple bugs in the implementation of maybe. classoid? is now a dumb test if an object could be a well-formed classoid; valid-classoid? tests for well-formedness. Move maybe tests. Make pprint* work better on methods.

basis/compiler/compiler.factor

@@ -151,7 +151,7 @@ M: optimizing-compiler update-call-sites ( class generic -- words )
     #! Words containing call sites with inferred type 'class'
     #! which inlined a method on 'generic'
     generic-call-sites-of swap '[
-        nip _ 2dup [ classoid? ] both?
+        nip _ 2dup [ valid-classoid? ] both?
         [ classes-intersect? ] [ 2drop f ] if
     ] assoc-filter keys ;
 

basis/prettyprint/backend/backend.factor

@@ -23,12 +23,22 @@ M: effect pprint* effect>string text ;
     ?effect-height 0 < [ end-group ] when ;
 
 ! Atoms
-: word-name* ( word -- str )
+GENERIC: word-name* ( obj -- str )
-    name>> "( no name )" or ;
+
+M: maybe word-name*
+    class>> word-name* "maybe: " prepend ;
+
+M: word word-name* ( word -- str )
+    [ name>> "( no name )" or ] [ record-vocab ] bi ;
 
 : pprint-word ( word -- )
-    [ record-vocab ]
+    [ word-name* ] [ word-style ] bi styled-text ;
-    [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
+
+GENERIC: pprint-class ( obj -- )
+
+M: maybe pprint-class pprint* ;
+
+M: class pprint-class \ f or pprint-word ;
 
 : pprint-prefix ( word quot -- )
     <block swap pprint-word call block> ; inline
@@ -40,12 +50,10 @@ M: word pprint*
     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
 
 M: method pprint*
-    [
+    <block
-        [
+    [ \ M\ pprint-word "method-class" word-prop pprint-class ]
-            [ "M\\ " % "method-class" word-prop word-name* % ]
+    [ "method-generic" word-prop pprint-word ] bi
-            [ " " % "method-generic" word-prop word-name* % ] bi
+    block> ;
-        ] "" make
-    ] [ word-style ] bi styled-text ;
 
 M: real pprint*
     number-base get {

basis/prettyprint/prettyprint-tests.factor

@@ -391,3 +391,18 @@ TUPLE: final-tuple ; final
 TUPLE: bob a b ;
 [ "maybe: bob\n" ] [ [  maybe: bob . ] with-string-writer ] unit-test
 [ "maybe: word\n" ] [ [  maybe: word . ] with-string-writer ] unit-test
+
+
+TUPLE: har a ;
+GENERIC: harhar ( obj -- obj )
+M: maybe: har harhar ;
+M: integer harhar M\ integer harhar drop ;
+[
+"""USING: prettyprint.tests ;
+M: maybe: har harhar ;
+
+USING: kernel math prettyprint.tests ;
+M: integer harhar M\\ integer harhar drop ;\n"""
+] [
+    [ \ harhar see-methods ] with-string-writer
+] unit-test

basis/prettyprint/sections/sections.factor

@@ -3,7 +3,8 @@
 USING: arrays generic hashtables io kernel math assocs
 namespaces make sequences strings io.styles vectors words
 prettyprint.config splitting classes continuations
-accessors sets vocabs.parser combinators vocabs ;
+accessors sets vocabs.parser combinators vocabs
+classes.maybe ;
 FROM: namespaces => set ;
 IN: prettyprint.sections
 
@@ -24,8 +25,16 @@ TUPLE: pprinter last-newline line-count indent ;
     dup pprinter-in get dup [ vocab-name ] when =
     [ drop ] [ pprinter-use get conjoin ] if ;
 
+GENERIC: vocabulary-name ( obj -- string )
+
+M: word vocabulary-name
+    vocabulary>> ;
+
+M: maybe vocabulary-name
+    class>> vocabulary>> ;
+
 : record-vocab ( word -- )
-    vocabulary>> {
+    vocabulary-name {
         { f [ ] }
         { "syntax" [ ] }
         [ (record-vocab) ]

basis/see/see.factor

@@ -81,7 +81,7 @@ M: hook-generic synopsis*
 
 M: method synopsis*
     [ definer. ]
-    [ "method-class" word-prop pprint-word ]
+    [ "method-class" word-prop pprint-class ]
     [ "method-generic" word-prop pprint-word ] tri ;
 
 M: mixin-instance synopsis*

basis/stack-checker/dependencies/dependencies.factor

@@ -78,7 +78,7 @@ TUPLE: depends-on-class-predicate class1 class2 result ;
 
 M: depends-on-class-predicate satisfied?
     {
-        [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
+        [ [ class1>> valid-classoid? ] [ class2>> valid-classoid? ] bi and ]
         [ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ]
     } 1&& ;
 
@@ -89,7 +89,7 @@ TUPLE: depends-on-instance-predicate object class result ;
 
 M: depends-on-instance-predicate satisfied?
     {
-        [ class>> classoid? ]
+        [ class>> valid-classoid? ]
         [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
     } 1&& ;
 
@@ -101,7 +101,7 @@ TUPLE: depends-on-next-method class generic next-method ;
 
 M: depends-on-next-method satisfied?
     {
-        [ class>> classoid? ]
+        [ class>> valid-classoid? ]
         [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
     } 1&& ;
 

core/classes/algebra/algebra.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes classes.private combinators accessors
+USING: accessors arrays assocs classes classes.private
-sequences arrays vectors assocs namespaces words sorting layouts
+combinators kernel math math.order namespaces sequences sorting
-math hashtables kernel.private sets math.order ;
+vectors words ;
 FROM: classes => members ;
 RENAME: members sets => set-members
 IN: classes.algebra
@@ -55,9 +55,16 @@ PRIVATE>
 GENERIC: classoid? ( obj -- ? )
 
 M: word classoid? class? ;
-M: anonymous-union classoid? members>> [ classoid? ] all? ;
+M: anonymous-union classoid? drop t ;
-M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
+M: anonymous-intersection classoid? drop t ;
-M: anonymous-complement classoid? class>> classoid? ;
+M: anonymous-complement classoid? drop t ;
+
+GENERIC: valid-classoid? ( obj -- ? )
+
+M: word valid-classoid? class? ;
+M: anonymous-union valid-classoid? members>> [ valid-classoid? ] all? ;
+M: anonymous-intersection valid-classoid? participants>> [ valid-classoid? ] all? ;
+M: anonymous-complement valid-classoid? class>> valid-classoid? ;
 
 : class<= ( first second -- ? )
     class<=-cache get [ (class<=) ] 2cache ;
@@ -255,7 +262,7 @@ ERROR: topological-sort-failed ;
     [ topological-sort-failed ] unless* ;
 
 : sort-classes ( seq -- newseq )
-    [ name>> ] sort-with >vector
+    [ class-name ] sort-with >vector
     [ dup empty? not ]
     [ dup largest-class [ swap remove-nth! ] dip ]
     produce nip ;

core/classes/builtin/builtin.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.private classes.algebra
+USING: classes classes.algebra.private classes.private kernel
-classes.algebra.private words kernel kernel.private namespaces
+kernel.private namespaces sequences words ;
-sequences math math.private combinators assocs quotations ;
 IN: classes.builtin
 
 SYMBOL: builtins

core/classes/classes.factor

@@ -40,6 +40,10 @@ SYMBOL: update-map
 
 SYMBOL: implementors-map
 
+GENERIC: class-name ( class -- string )
+
+M: class class-name name>> ;
+
 GENERIC: rank-class ( class -- n )
 
 GENERIC: reset-class ( class -- )

core/classes/maybe/maybe-tests.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.maybe eval generic.single kernel tools.test
+math classes accessors slots classes.algebra ;
+IN: classes.maybe.tests
+
+[ t ] [ 3 maybe: integer instance? ] unit-test
+[ t ] [ f maybe: integer instance? ] unit-test
+[ f ] [ 3.0 maybe: integer instance? ] unit-test
+
+TUPLE: maybe-integer-container { something maybe: integer } ;
+
+[ f ] [ maybe-integer-container new something>> ] unit-test
+[ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
+[ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
+
+TUPLE: self-pointer { next maybe: self-pointer } ;
+
+[ T{ self-pointer { next T{ self-pointer } } } ]
+[ self-pointer new self-pointer new >>next ] unit-test
+
+[ t ] [ f maybe: f instance? ] unit-test
+
+PREDICATE: natural < maybe: integer
+    0 > ;
+
+[ f ] [ -1 natural? ] unit-test
+[ f ] [ 0 natural? ] unit-test
+[ t ] [ 1 natural? ] unit-test
+
+[ "USE: math maybe: maybe: integer" eval( -- obj ) ] [ error>> bad-slot-value? ] must-fail-with
+
+INTERSECTION: only-f maybe: integer POSTPONE: f ;
+
+[ t ] [ f only-f instance? ] unit-test
+[ f ] [ t only-f instance? ] unit-test
+[ f ] [ 30 only-f instance? ] unit-test
+
+UNION: ?integer-float maybe: integer maybe: float ;
+
+[ t ] [ 30 ?integer-float instance? ] unit-test
+[ t ] [ 30.0 ?integer-float instance? ] unit-test
+[ t ] [ f ?integer-float instance? ] unit-test
+[ f ] [ t ?integer-float instance? ] unit-test
+
+TUPLE: foo ;
+GENERIC: lol ( obj -- string )
+M: maybe: foo lol drop "lol" ;
+
+[ "lol" ] [ foo new lol ] unit-test
+[ "lol" ] [ f lol ] unit-test
+[ 3 lol ] [ no-method? ] must-fail-with
+
+TUPLE: foo2 a ;
+GENERIC: lol2 ( obj -- string )
+M: maybe: foo lol2 drop "lol2" ;
+M: f lol2 drop "lol22" ;
+
+[ "lol2" ] [ foo new lol2 ] unit-test
+[ "lol22" ] [ f lol2 ] unit-test
+[ 3 lol2 ] [ no-method? ] must-fail-with
+
+[ t ] [ \ + <maybe> classoid? ] unit-test
+[ f ] [ \ + <maybe> valid-classoid? ] unit-test

core/classes/maybe/maybe.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2011 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra
-classes.algebra.private classes.private effects generic
+classes.algebra.private classes.private classes.union.private
-kernel sequences words classes.union classes.union.private ;
+effects kernel words ;
 IN: classes.maybe
 
 TUPLE: maybe { class word initial: object read-only } ;
@@ -12,21 +12,25 @@ C: <maybe> maybe
 M: maybe instance?
     over [ class>> instance? ] [ 2drop t ] if ;
 
-M: maybe normalize-class
+: maybe-class-or ( maybe -- classoid )
     class>> \ f class-or ;
 
+M: maybe normalize-class
+    maybe-class-or ;
+
 M: maybe classoid? drop t ;
 
+M: maybe valid-classoid? class>> valid-classoid? ;
+
 M: maybe rank-class drop 6 ;
 
 M: maybe (flatten-class)
-    class>> (flatten-class) ;
+    maybe-class-or (flatten-class) ;
 
 M: maybe effect>type ;
 
-M: maybe method-word-name
-    [ class>> name>> ] [ name>> ] bi* "=>" glue ;
-
 M: maybe union-of-builtins?
     class>> union-of-builtins? ;
 
+M: maybe class-name
+    class>> name>> ;

core/classes/union/union-tests.factor

@@ -107,44 +107,3 @@ M: a-union test-generic ;
 [ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
 
 [ f ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
-
-! Test maybe
-
-[ t ] [ 3 maybe: integer instance? ] unit-test
-[ t ] [ f maybe: integer instance? ] unit-test
-[ f ] [ 3.0 maybe: integer instance? ] unit-test
-
-TUPLE: maybe-integer-container { something maybe: integer } ;
-
-[ f ] [ maybe-integer-container new something>> ] unit-test
-[ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
-[ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
-
-TUPLE: self-pointer { next maybe: self-pointer } ;
-
-[ T{ self-pointer { next T{ self-pointer } } } ]
-[ self-pointer new self-pointer new >>next ] unit-test
-
-[ t ] [ f maybe: f instance? ] unit-test
-
-PREDICATE: natural < maybe: integer
-    0 > ;
-
-[ f ] [ -1 natural? ] unit-test
-[ f ] [ 0 natural? ] unit-test
-[ t ] [ 1 natural? ] unit-test
-
-[ "USE: math maybe: maybe: integer" eval( -- obj ) ] [ error>> bad-slot-value? ] must-fail-with
-
-INTERSECTION: only-f maybe: integer POSTPONE: f ;
-
-[ t ] [ f only-f instance? ] unit-test
-[ f ] [ t only-f instance? ] unit-test
-[ f ] [ 30 only-f instance? ] unit-test
-
-UNION: ?integer-float maybe: integer maybe: float ;
-
-[ t ] [ 30 ?integer-float instance? ] unit-test
-[ t ] [ 30.0 ?integer-float instance? ] unit-test
-[ t ] [ f ?integer-float instance? ] unit-test
-[ f ] [ t ?integer-float instance? ] unit-test

core/generic/generic.factor

@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets ;
+sets classes.maybe ;
 FROM: namespaces => set ;
 IN: generic
 
@@ -112,6 +112,9 @@ GENERIC# method-word-name 1 ( class generic -- string )
 M: class method-word-name ( class generic -- string )
     [ name>> ] bi@ "=>" glue ;
 
+M: maybe method-word-name
+    [ class>> name>> ] [ name>> ] bi* "=>" glue ;
+
 M: method parent-word
     "method-generic" word-prop ;
 
@@ -129,8 +132,14 @@ M: method crossref?
     [ method-word-name f <word> ] [ method-word-props ] 2bi
     >>props ;
 
+GENERIC: implementor-class ( obj -- class )
+
+M: maybe implementor-class class>> ;
+
+M: class implementor-class ;
+
 : with-implementors ( class generic quot -- )
-    [ swap implementors-map get at ] dip call ; inline
+    [ swap implementor-class implementors-map get at ] dip call ; inline
 
 : reveal-method ( method class generic -- )
     [ [ conjoin ] with-implementors ]

core/parser/parser-docs.factor

@@ -197,7 +197,7 @@ HELP: scan-number
 { $errors "Throws an error if the token is not a number or end of file is reached." }
 $parsing-note ;
 
-HELP: parse-step
+HELP: parse-until-step
 { $values { "accum" vector } { "end" word } { "?" "a boolean" } }
 { $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." }
 $parsing-note ;

core/parser/parser.factor

@@ -100,13 +100,10 @@ ERROR: staging-violation word ;
         V{ } clone swap execute-parsing first
     ] when ;
 
-ERROR: classoid-expected word ;
-
 : scan-class ( -- class )
-    scan-object \ f or
+    scan-object \ f or ;
-    dup classoid? [ classoid-expected ] unless ;
 
-: parse-step ( accum end -- accum ? )
+: parse-until-step ( accum end -- accum ? )
     (scan-datum) {
         { [ 2dup eq? ] [ 2drop f ] }
         { [ dup not ] [ drop unexpected-eof t ] }
@@ -116,7 +113,7 @@ ERROR: classoid-expected word ;
     } cond ;
 
 : (parse-until) ( accum end -- accum )
-    [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
+    [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
 
 : parse-until ( end -- vec )
     100 <vector> swap (parse-until) ;