extra/classes/prettyprinter/prettyprinter.factor

   1 ! Copyright (C) 2023 Jean-Marc Lugrin.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3
   4 ! Print a class heierarchy in the listener
   5 ! or to a file: "TESTDUMP.TXT" utf8 [ gadget hierarchy. ] with-file-writer
   6
   7
   8 USING:  classes hashtables ui.gadgets assocs kernel sequences prettyprint  vectors
   9 math io formatting strings sorting accessors io.styles vocabs ;
  10
  11 IN: classes.prettyprinter
  12
  13 ERROR: not-a-class-error ;
  14
  15 <PRIVATE
  16
  17 CONSTANT: in-col 40
  18
  19 : add-child  ( c h  -- )
  20     over ! ( c h -- c h c )
  21     superclass-of  ! ( c h c -- c h s )
  22     swap at* ! (c h s -- c s h -- c v ? ) vector for superclass but if f ignore
  23         [ swap suffix! drop ]  ! ( c v -- )
  24         [ 2drop ]
  25     if
  26 ;
  27
  28 : print-class-name ( c -- )
  29     dup name>> swap write-object
  30 ;
  31
  32
  33 : print-in ( c -- )
  34     vocabulary>> lookup-vocab dup name>>
  35     dup ".private" tail? [ " P" ]  [ "  " ] if  write ! Mark if private
  36     " IN: " write
  37     swap write-object
  38 ;
  39
  40 : print-leader ( i -- )
  41     ! 2 * CHAR: . <string>  write ! leader
  42     [ "| " ] replicate "" concat-as write
  43     ! 1 CHAR: \x20 <string> write
  44 ;
  45
  46 : print-class ( c i -- )
  47     2dup print-leader print-class-name ! ( c i -- c i )
  48     2 * over name>> length + ! Current column  c ci --
  49     dup in-col < [ in-col swap - CHAR: \x20 <string>  write  ] [ drop  ] if
  50     print-in
  51     nl
  52 ;
  53
  54 : print-superclasses ( c -- )
  55     superclass-of dup
  56     [ " < " write
  57         [ print-class-name ]
  58         [ print-superclasses ] bi
  59     ]
  60     [ drop ]
  61     if
  62 ;
  63
  64 : print-root-class ( c -- )
  65     [ print-class-name ]
  66     [ print-superclasses ] bi
  67     nl
  68 ;
  69
  70  :: print-children ( h c i -- )
  71     i 0 = [ c print-root-class ] [ c i print-class  ] if
  72     c h at
  73     [ h swap i 1 + print-children ] each
  74  ;
  75
  76 PRIVATE>
  77
  78 : class-hierarchy ( -- hash )
  79     ! Hastable class -> empty mutable vector
  80     classes  [ drop V{ } clone ] zip-with >hashtable
  81     ! for each child-class, add it to its parent vector
  82     classes [  over add-child ] each
  83     [ sort ] assoc-map
  84 ;
  85
  86 : hierarchy. ( class -- )
  87     dup class? [ not-a-class-error ] unless
  88     class-hierarchy
  89     ! Print from the desired root class
  90     swap 0 print-children
  91 ;