Change name of vocabulary review corrections

diff --git a/extra/classes/hierarchy/authors.txt b/extra/classes/hierarchy/authors.txt
new file mode 100644 (file)
index 0000000..11b4b75
--- /dev/null
+++ b/extra/classes/hierarchy/authors.txt
@@ -0,0 +1 @@
+Jean-Marc Lugrin

diff --git a/extra/classes/hierarchy/hierarchy-docs.factor b/extra/classes/hierarchy/hierarchy-docs.factor
new file mode 100644 (file)
index 0000000..009475c
--- /dev/null
+++ b/extra/classes/hierarchy/hierarchy-docs.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2023 Jean-Marc Lugrin.
+! See https://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: classes.hierarchy
+
+ARTICLE: "classes.hierarchy" "Print the hierarchy of a class"
+{ $vocab-link "classes.hierarchy" } " supports the printing of the class hierarchy to the listener or to any text stream." $nl
+"The class name and vocab name are clickable, a P indicates that the class is PRIVATE." $nl 
+"See " { $link hierarchy. } "."
+;
+
+HELP: hierarchy.
+{ $values { "class" "a class, use " { $snippet "tuple" } " to print the whole hierarchy" }  }
+{ $description "Print the class hierarchy layout on the output stream, with the name of its vocabulary." }
+{ $errors "Throws an error if " { $snippet "class" } " is not a class." }
+{ $examples
+    { $unchecked-example "tuple hierarchy." }  
+    { $unchecked-example " \"GADGETS.TXT\" utf8 [ gadget hierarchy. ] with-file-writer" } 
+}
+;
+
+HELP: class-hierarchy
+{ $values { "hash" "An " { $snippet "hashtable" } " mapping classes to list of children" }  }
+{ $description "Extract the hierarchy of all classes in the form of an hashtable" 
+    "with the class as the key and a vector of all children class in alphabetic order as a child." }
+{ $notes { "This is made public for other tools that want to explore the class hierarch." } }
+;
+
+HELP: not-a-class-error
+{ $description "Throws a " { $link not-a-class-error } "." }
+{ $error-description "Thrown by " { $link hierarchy. } " if the parameter is not a class." } 
+;
+
+ABOUT: "classes.hierarchy"

diff --git a/extra/classes/hierarchy/hierarchy-tests.factor b/extra/classes/hierarchy/hierarchy-tests.factor
new file mode 100644 (file)
index 0000000..f6de237
--- /dev/null
+++ b/extra/classes/hierarchy/hierarchy-tests.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2023 Jean-Marc Lugrin.
+! See https://factorcode.org/license.txt for BSD license.
+
+USING: tools.test classes.hierarchy assocs io.streams.string ;
+IN: classes.hierarchy.tests
+
+TUPLE: troot a b c ;
+
+TUPLE: tchild1 < troot aa ;
+
+TUPLE: tchild2 < troot  bb ;
+
+{ { tchild1 tchild2 } }  [ troot class-hierarchy at ] unit-test 
+
+[ f hierarchy. ] must-fail
+
+{ "t < word\n" } [  [ t hierarchy. ] with-string-writer ] unit-test
+{ "tchild1 < troot < tuple\n" } [  [ tchild1 hierarchy. ] with-string-writer ] unit-test
+{ "troot < tuple\n| tchild1                                  IN: classes.hierarchy.tests\n| tchild2                                  IN: classes.hierarchy.tests\n" } 
+    [  [ troot hierarchy. ] with-string-writer ] unit-test
\ No newline at end of file

diff --git a/extra/classes/hierarchy/hierarchy.factor b/extra/classes/hierarchy/hierarchy.factor
new file mode 100644 (file)
index 0000000..aa26825
--- /dev/null
+++ b/extra/classes/hierarchy/hierarchy.factor
@@ -0,0 +1,87 @@
+! Copyright (C) 2023 Jean-Marc Lugrin.
+! See https://factorcode.org/license.txt for BSD license.
+
+! Print a class hierarchy in the listener
+! or to a file: "TESTDUMP.TXT" utf8 [ gadget hierarchy. ] with-file-writer
+
+
+USING:  classes hashtables ui.gadgets assocs kernel sequences prettyprint  vectors 
+math io formatting strings sorting accessors io.styles vocabs ;
+
+IN: classes.hierarchy
+
+ERROR: not-a-class-error ;
+
+<PRIVATE
+
+CONSTANT: in-col 40
+
+: add-child  ( c h  -- )
+    over 
+    superclass-of  
+    swap at* 
+        [ swap suffix! drop ] 
+        [ 2drop ] 
+    if 
+;
+
+: print-class-name ( c -- )
+    dup name>> swap write-object
+;
+
+
+: print-in ( c -- )
+    vocabulary>> lookup-vocab dup name>> 
+    dup ".private" tail? [ " P" ]  [ "  " ] if  write ! Mark if private
+    " IN: " write 
+    swap write-object 
+;
+
+: print-leader ( i -- )
+    [ "| " ] replicate "" concat-as write  
+;
+
+: print-class ( c i -- ) 
+    2dup print-leader print-class-name
+    2 * over name>> length +  
+    dup in-col < [ in-col swap - CHAR: \x20 <string>  write  ] [ drop  ] if
+    print-in 
+    nl 
+;
+
+: print-superclasses ( c -- )
+    superclass-of 
+    [ " < " write
+        [ print-class-name ] 
+        [ print-superclasses ] bi 
+    ] when*
+;
+
+: print-root-class ( c -- ) 
+    [ print-class-name ]
+    [ print-superclasses ] bi
+    nl
+;
+
+ :: print-children ( h c i -- )
+    c i [ print-root-class ] [ print-class ] if-zero
+    c h at
+    [ h swap i 1 + print-children ] each
+ ;
+
+PRIVATE>
+
+: class-hierarchy ( -- hash )
+    ! Hashtable class -> empty mutable vector
+    classes  [ drop V{ } clone ] H{ } zip-with-as
+    ! for each child-class, add it to its parent vector
+    classes [  over add-child ] each
+    [ sort ] assoc-map
+;
+
+: hierarchy. ( class -- )
+    dup class? [ not-a-class-error ] unless
+    class-hierarchy
+    ! Print from the desired root class
+    swap 0 print-children 
+;   

diff --git a/extra/classes/hierarchy/summary.txt b/extra/classes/hierarchy/summary.txt
new file mode 100644 (file)
index 0000000..723c429
--- /dev/null
+++ b/extra/classes/hierarchy/summary.txt
@@ -0,0 +1 @@
+Print a class hierarchy
\ No newline at end of file

diff --git a/extra/classes/hierarchy/tags.txt b/extra/classes/hierarchy/tags.txt
new file mode 100644 (file)
index 0000000..8ba7ae8
--- /dev/null
+++ b/extra/classes/hierarchy/tags.txt
@@ -0,0 +1,2 @@
+tools
+reflection