From: Jean-Marc Lugrin Date: Thu, 9 Nov 2023 09:43:25 +0000 (+0100) Subject: added vocab prettyprinter to classes in extra X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=bd22303d313a91889edbd455d78964aa4086a0d9 added vocab prettyprinter to classes in extra --- diff --git a/extra/classes/prettyprinter/authors.txt b/extra/classes/prettyprinter/authors.txt new file mode 100644 index 0000000000..11b4b75a08 --- /dev/null +++ b/extra/classes/prettyprinter/authors.txt @@ -0,0 +1 @@ +Jean-Marc Lugrin diff --git a/extra/classes/prettyprinter/prettyprinter-docs.factor b/extra/classes/prettyprinter/prettyprinter-docs.factor new file mode 100644 index 0000000000..f457a0945d --- /dev/null +++ b/extra/classes/prettyprinter/prettyprinter-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.prettyprinter + +ARTICLE: "classes.prettyprinter" "Print the hierarchy of a class" +{ $vocab-link "classes.prettyprinter" } " 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 classs 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.prettyprinter" diff --git a/extra/classes/prettyprinter/prettyprinter-tests.factor b/extra/classes/prettyprinter/prettyprinter-tests.factor new file mode 100644 index 0000000000..1bb0664d35 --- /dev/null +++ b/extra/classes/prettyprinter/prettyprinter-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.prettyprinter assocs io.streams.string ; +IN: classes.prettyprinter.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.prettyprinter.tests\n| tchild2 IN: classes.prettyprinter.tests\n" } + [ [ troot hierarchy. ] with-string-writer ] unit-test \ No newline at end of file diff --git a/extra/classes/prettyprinter/prettyprinter.factor b/extra/classes/prettyprinter/prettyprinter.factor new file mode 100644 index 0000000000..4d6e8542a2 --- /dev/null +++ b/extra/classes/prettyprinter/prettyprinter.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2023 Jean-Marc Lugrin. +! See https://factorcode.org/license.txt for BSD license. + +! Print a class heierarchy 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.prettyprinter + +ERROR: not-a-class-error ; + +> 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 -- ) + ! 2 * CHAR: . write ! leader + [ "| " ] replicate "" concat-as write + ! 1 CHAR: \x20 write +; + +: print-class ( c i -- ) + 2dup print-leader print-class-name ! ( c i -- c i ) + 2 * over name>> length + ! Current column c ci -- + dup in-col < [ in-col swap - CHAR: \x20 write ] [ drop ] if + print-in + nl +; + +: print-superclasses ( c -- ) + superclass-of dup + [ " < " write + [ print-class-name ] + [ print-superclasses ] bi + ] + [ drop ] + if +; + +: print-root-class ( c -- ) + [ print-class-name ] + [ print-superclasses ] bi + nl +; + + :: print-children ( h c i -- ) + i 0 = [ c print-root-class ] [ c i print-class ] if + c h at + [ h swap i 1 + print-children ] each + ; + +PRIVATE> + +: class-hierarchy ( -- hash ) + ! Hastable class -> empty mutable vector + classes [ drop V{ } clone ] zip-with >hashtable + ! 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/prettyprinter/summary.txt b/extra/classes/prettyprinter/summary.txt new file mode 100644 index 0000000000..723c4290d0 --- /dev/null +++ b/extra/classes/prettyprinter/summary.txt @@ -0,0 +1 @@ +Print a class hierarchy \ No newline at end of file diff --git a/extra/classes/prettyprinter/tags.txt b/extra/classes/prettyprinter/tags.txt new file mode 100644 index 0000000000..8ba7ae8503 --- /dev/null +++ b/extra/classes/prettyprinter/tags.txt @@ -0,0 +1,2 @@ +tools +reflection