More work on the definition protocol

TODO.FACTOR.txt

@@ -25,13 +25,6 @@
 - constant branch folding
 - type inference at branch merge points
 - remove literal table
-- forgetting a class should remove its methods from all generic words
-  - offer to remove generic words which are not called and have no
-    methods
-- forgetting a tuple class should forget the constructor
-- T{ link f "foo" "bar" } see
-- T{ link f "foo" "bar" } jedit
-- T{ link f "foo" "bar" } reload
 - generic 'define ( asset def -- )'
 
 ========================================================================

library/definitions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: definitions
-USING: sequences ;
+USING: kernel sequences ;
 
 GENERIC: see ( defspec -- )
 

library/generic/classes.factor

@@ -124,7 +124,7 @@ SYMBOL: class<cache
     [ \ dup , % , [ drop f ] , \ if , ] [ ] make
     define-predicate ;
 
-PREDICATE: word predicate "definition" word-prop ;
+PREDICATE: class predicate "definition" word-prop ;
 
 ! Union classes for dispatch on multiple classes.
 : union-predicate ( members -- list )
@@ -138,8 +138,11 @@ PREDICATE: word predicate "definition" word-prop ;
     3dup nip set-members pick define-class
     union-predicate define-predicate ;
 
-PREDICATE: word union members ;
+PREDICATE: class union members ;
 
 ! Definition protocol
-M: class forget
+: forget-class ( class -- )
+    dup "predicate" word-prop [ forget ] each
     dup flatten-class typemap get remove-hash forget-word ;
+
+M: class forget forget-class ;

library/generic/methods.factor

@@ -50,6 +50,8 @@ M: method-spec where
     dup first2 "methods" word-prop hash method-loc
     [ ] [ second where ] ?if ;
 
+M: method-spec subdefs drop f ;
+
 M: generic subdefs
     dup order [ swap 2array ] map-with ;
 

library/generic/tuple.factor

@@ -47,7 +47,7 @@ IN: generic
     2dup delegate-slots swap append "slots" set-word-prop
     define-slots ;
 
-PREDICATE: word tuple-class "tuple-size" word-prop ;
+PREDICATE: class tuple-class "tuple-size" word-prop ;
 
 TUPLE: check-tuple class ;
 : check-tuple ( class -- class )
@@ -62,8 +62,8 @@ TUPLE: check-tuple class ;
     ] [ ] make define-compound ;
 
 : default-constructor ( tuple -- )
-    [ create-constructor ] keep
+    dup create-constructor 2dup "constructor" set-word-prop
-    dup "slots" word-prop unclip drop <reversed>
+    swap dup "slots" word-prop unclip drop <reversed>
     [ [ tuck ] swap peek add ] map concat >quotation
     define-constructor ;
 
@@ -98,3 +98,7 @@ M: tuple = ( obj tuple -- ? )
 : >tuple ( seq -- tuple )
     >vector dup first "tuple-size" word-prop over set-length
     >array array>tuple ;
+
+! Definition protocol
+M: tuple-class forget
+    dup "constructor" word-prop forget forget-class ;

library/help/help.factor

@@ -21,7 +21,7 @@ M: word article-content
 : $title ( article -- )
     title-style [
         title-style [
-            dup [ 1array $link ] ($block) $where
+            dup [ 1array $link ] ($block) $doc-path
         ] with-nesting
     ] with-style terpri ;
 

library/help/markup.factor

@@ -123,10 +123,6 @@ M: word print-element { } swap execute ;
     ] ($heading) ;
 
 ! Some links
-M: link article-title link-name article-title ;
-M: link article-content link-name article-content ;
-M: link summary "Link: " swap link-name unparse append ;
-
 GENERIC: >link ( obj -- obj )
 
 M: word >link ;
@@ -156,12 +152,12 @@ M: object >link <link> ;
 : $see-also ( content -- )
     "See also" $heading $links ;
 
-: $where ( article -- )
+: $doc-path ( article -- )
-    where dup empty? [
+    doc-path dup empty? [
         drop
     ] [
         [
-            where-style [
+            doc-path-style [
                 "Parent topics: " write $links
             ] with-style
         ] ($block)

library/help/search.factor

@@ -67,9 +67,9 @@ SYMBOL: term-index
         dup articles get remove-hash
     ] when drop ;
 
-: add-article ( name title element -- )
+: add-article ( name article -- )
-    pick remove-article
+    over remove-article
-    pick >r (add-article) r>
+    over >r swap articles get set-hash r>
     dup xref-article index-article ;
 
 : remove-word-help ( word -- )
@@ -85,3 +85,8 @@ SYMBOL: term-index
 
 : search-help. ( phrase -- )
     search-help [ first ] map help-outliner ;
+
+! Definition protocol
+M: link forget link-name remove-article ;
+
+M: word-link forget f "help" set-word-prop ;

library/help/stylesheet.factor

@@ -30,7 +30,7 @@ USING: styles ;
         { border-width 5 }
     } ;
 
-: where-style
+: doc-path-style
     H{ { font-size 10 } } ;
 
 : heading-style

library/help/syntax.factor

@@ -4,10 +4,15 @@ IN: !syntax
 USING: arrays help kernel parser sequences syntax words ;
 
 : !HELP:
-    scan-word bootstrap-word dup [
+    scan-word bootstrap-word
+    dup dup location "help-loc" set-word-prop
+    [
         >array unclip swap >r "stack-effect" set-word-prop r>
         set-word-help
     ] f ; parsing
 
 : !ARTICLE:
-    [ >array [ first2 ] keep 2 tail add-article ] f ; parsing
+    [
+        >array [ first2 ] keep 2 tail location <article>
+        add-article
+    ] f ; parsing

library/help/topics.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: help
-USING: arrays errors generic graphs hashtables io kernel
+USING: arrays definitions errors generic graphs hashtables
-namespaces prettyprint sequences words ;
+inspector io kernel namespaces prettyprint sequences words ;
 
 ! Markup
 GENERIC: print-element
@@ -10,7 +10,7 @@ GENERIC: print-element
 ! Help articles
 SYMBOL: articles
 
-TUPLE: article title content ;
+TUPLE: article title content loc ;
 
 TUPLE: no-article name ;
 : no-article ( name -- ) <no-article> throw ;
@@ -18,18 +18,19 @@ TUPLE: no-article name ;
 : article ( name -- article )
     dup articles get hash [ ] [ no-article ] ?if ;
 
-: (add-article) ( name title element -- )
-    <article> swap articles get set-hash ;
-
 M: object article-title article article-title ;
 M: object article-content article article-content ;
 
+TUPLE: link name ;
+
+M: link article-title link-name article-title ;
+M: link article-content link-name article-content ;
+M: link summary "Link: " swap link-name unparse append ;
+
 ! Special case: f help
 M: f article-title drop \ f article-title ;
 M: f article-content drop \ f article-content ;
 
-TUPLE: link name ;
-
 : word-help ( word -- content ) "help" word-prop ;
 
 : all-articles ( -- seq )
@@ -59,12 +60,12 @@ DEFER: $subsection
 : parents ( article -- seq )
     dup link? [ link-name ] when parent-graph get in-edges ;
 
-: (where) ( article -- )
+: (doc-path) ( article -- )
     dup , parents [ word? not ] subset dup empty?
-    [ drop ] [ [ (where) ] each ] if ;
+    [ drop ] [ [ (doc-path) ] each ] if ;
 
-: where ( article -- seq )
+: doc-path ( article -- seq )
-    [ (where) ] { } make 1 tail prune ;
+    [ (doc-path) ] { } make 1 tail prune ;
 
 : xref-article ( article -- )
     [ children ] parent-graph get add-vertex ;
@@ -74,3 +75,29 @@ DEFER: $subsection
 
 : xref-help ( -- )
     all-articles [ children ] parent-graph get build-graph ;
+
+! Definition protocol
+M: link where link-name article article-loc ;
+
+M: link (synopsis)
+    \ ARTICLE: pprint-word
+    dup link-name pprint*
+    article-title pprint* ;
+
+M: link definition article-content t ;
+
+M: link see (see) ;
+
+PREDICATE: link word-link link-name word? ;
+
+M: word-link where link-name "help-loc" word-prop ;
+
+M: word-link (synopsis)
+    \ HELP: pprint-word
+    link-name dup pprint-word
+    "stack-effect" word-prop pprint* ;
+
+M: word-link definition
+    link-name "help" word-prop t ;
+
+M: word-link see (see) ;

library/help/topics.facts

@@ -25,11 +25,6 @@ HELP: article-content "( topic -- element )"
 { $values { "topic" "an article name or a word" } { "element" "a markup element" } }
 { $description "Outputs the content of a specific help article." } ;
 
-HELP: (add-article) "( name title element -- )"
-{ $values { "name" "an object" } { "title" "a string" } { "element" "a markup element" } }
-{ $description "Adds a help article to the " { $link articles } " hashtable." }
-{ $notes "This word is used to implement " { $link POSTPONE: ARTICLE: } "." } ;
-
 HELP: all-articles "( -- seq )"
 { $values { "seq" "a sequence" } }
 { $description "Outputs a sequence of all help article names, and all words with documentation." } ;
@@ -55,11 +50,11 @@ HELP: parents "( topic -- seq )"
 { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
 { $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection." } ;
 
-HELP: where "( topic -- seq )"
+HELP: doc-path "( topic -- seq )"
 { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
 { $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." }
 { $examples
-    { $example "\"sequences\" where ." "{ \"collections\" \"handbook\" }" }
+    { $example "\"sequences\" doc-path ." "{ \"collections\" \"handbook\" }" }
 } ;
 
 HELP: xref-article "( topic -- )"

library/test/generic.factor

@@ -1,5 +1,6 @@
-USING: alien arrays generic hashtables io kernel math namespaces
+USING: alien arrays definitions generic hashtables io kernel
-parser prettyprint sequences strings test vectors words ;
+math namespaces parser prettyprint sequences strings test
+vectors words ;
 IN: temporary
 
 GENERIC: class-of

library/test/help/topics.factor

@@ -1,11 +1,11 @@
 IN: temporary
-USING: help kernel sequences test words ;
+USING: definitions help kernel sequences test words ;
 
 ! Test help cross-referencing
 
-{ "test" "b" } "Test B" { "Hello world." } add-article
+{ "test" "b" } "Test B" { "Hello world." } f <article> add-article
 
-{ "test" "a" } "Test A" { { $subsection { "test" "b" } } } add-article
+{ "test" "a" } "Test A" { { $subsection { "test" "b" } } } f <article> add-article
 
 { "test" "a" } remove-article
 
@@ -13,7 +13,7 @@ USING: help kernel sequences test words ;
 
 SYMBOL: foo
 
-{ "test" "a" } "Test A" { { $subsection foo } } add-article
+{ "test" "a" } "Test A" { { $subsection foo } } f <article> add-article
 
 foo { $description "Fie foe fee" } set-word-help
 

library/test/inference.factor

@@ -1,6 +1,7 @@
 IN: temporary
 USING: arrays errors generic inference kernel kernel-internals
-math math-internals namespaces parser sequences test vectors ;
+math math-internals namespaces parser sequences strings test
+vectors ;
 
 [ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
 
@@ -207,6 +208,13 @@ DEFER: blah4
 
 [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
 
+! Regression
+: bad-input#
+    dup string? [ 2array throw ] unless
+    over string? [ 2array throw ] unless ;
+
+[ { 2 2 } ] [ [ bad-input# ] infer ] unit-test
+
 ! Regression
 
 ! This order of branches works

library/test/prettyprint.factor

@@ -1,4 +1,4 @@
-USING: alien io kernel math prettyprint sequences
+USING: alien io definitions kernel math prettyprint sequences
 test words inference namespaces vectors ;
 IN: temporary
 

library/test/tuple.factor

@@ -1,7 +1,10 @@
-USING: errors generic kernel kernel-internals math parser
+USING: errors definitions generic kernel kernel-internals math
-sequences test words hashtables ;
+parser sequences test words hashtables namespaces ;
 IN: temporary
 
+[ t ] [ \ tuple-class \ class class< ] unit-test
+[ f ] [ \ class \ tuple-class class< ] unit-test
+
 TUPLE: rect x y w h ;
 C: rect
     [ set-rect-h ] keep
@@ -116,3 +119,12 @@ GENERIC: <yo-momma>
 TUPLE: yo-momma ;
 
 [ f ] [ \ <yo-momma> generic? ] unit-test
+
+! Test forget
+[ t ] [ \ yo-momma class? ] unit-test
+[ ] [ \ yo-momma forget ] unit-test
+[ f ] [ \ yo-momma typemap get hash-values memq? ] unit-test
+
+[ f ] [ \ yo-momma interned? ] unit-test
+[ f ] [ \ yo-momma? interned? ] unit-test
+[ f ] [ \ <yo-momma> interned? ] unit-test