core/inspector/inspector.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic hashtables io kernel assocs math
   4 namespaces prettyprint sequences strings io.styles vectors words
   5 quotations mirrors splitting math.parser classes vocabs refs
   6 sets sorting ;
   7 IN: inspector
   8
   9 GENERIC: summary ( object -- string )
  10
  11 : object-summary ( object -- string )
  12     class word-name " instance" append ;
  13
  14 M: object summary object-summary ;
  15
  16 M: input summary
  17     [
  18         "Input: " %
  19         input-string "\n" split1 swap %
  20         "..." "" ? %
  21     ] "" make ;
  22
  23 M: word summary synopsis ;
  24
  25 M: sequence summary
  26     [
  27         dup class word-name %
  28         " with " %
  29         length #
  30         " elements" %
  31     ] "" make ;
  32
  33 M: assoc summary
  34     [
  35         dup class word-name %
  36         " with " %
  37         assoc-size #
  38         " entries" %
  39     ] "" make ;
  40
  41 ! Override sequence => integer instance
  42 M: f summary object-summary ;
  43
  44 M: integer summary object-summary ;
  45
  46 : value-editor ( path -- )
  47     [
  48         [ pprint-short ] presented-printer set
  49         dup presented-path set
  50     ] H{ } make-assoc
  51     [ get-ref pprint-short ] with-nesting ;
  52
  53 SYMBOL: +sequence+
  54 SYMBOL: +number-rows+
  55 SYMBOL: +editable+
  56
  57 : write-slot-editor ( path -- )
  58     [
  59         +editable+ get [
  60             value-editor
  61         ] [
  62             get-ref pprint-short
  63         ] if
  64     ] with-cell ;
  65
  66 : write-key ( mirror key -- )
  67     +sequence+ get
  68     [ 2drop ] [ <key-ref> write-slot-editor ] if ;
  69
  70 : write-value ( mirror key -- )
  71     <value-ref> write-slot-editor ;
  72
  73 : describe-row ( obj key n -- )
  74     [
  75         +number-rows+ get [ pprint-cell ] [ drop ] if
  76         2dup write-key write-value
  77     ] with-row ;
  78
  79 : summary. ( obj -- ) [ summary ] keep write-object nl ;
  80
  81 : sorted-keys ( assoc -- alist )
  82     dup mirror? [ keys ] [
  83         keys
  84         [ [ unparse-short ] keep ] { } map>assoc
  85         sort-keys values
  86     ] if ;
  87
  88 : describe* ( obj flags -- )
  89     clone [
  90         dup summary.
  91         make-mirror dup sorted-keys dup empty? [
  92             2drop
  93         ] [
  94             dup enum? [ +sequence+ on ] when
  95             standard-table-style [
  96                 dup length
  97                 rot [ -rot describe-row ] curry 2each
  98             ] tabular-output
  99         ] if
 100     ] bind ;
 101
 102 : describe ( obj -- ) H{ } describe* ;
 103
 104 : namestack. ( seq -- )
 105     [ [ global eq? not ] filter [ keys ] gather ] keep
 106     [ dupd assoc-stack ] curry H{ } map>assoc describe ;
 107
 108 : .vars ( -- )
 109     namestack namestack. ;
 110
 111 SYMBOL: inspector-hook
 112
 113 [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
 114
 115 SYMBOL: inspector-stack
 116
 117 SYMBOL: me
 118
 119 : reinspect ( obj -- )
 120     dup me set
 121     dup make-mirror dup mirror set keys \ keys set
 122     inspector-hook get call ;
 123
 124 : (inspect) ( obj -- )
 125     dup inspector-stack get push reinspect ;
 126
 127 : key@ ( n -- key ) \ keys get nth ;
 128
 129 : &push ( -- obj ) me get ;
 130
 131 : &at ( n -- ) key@ mirror get at (inspect) ;
 132
 133 : &back ( -- )
 134     inspector-stack get
 135     dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
 136
 137 : &add ( value key -- ) mirror get set-at &push reinspect ;
 138
 139 : &put ( value n -- ) key@ &add ;
 140
 141 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
 142
 143 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
 144
 145 : &help ( -- )
 146     #! A tribute to Slate:
 147     "You are in a twisty little maze of objects, all alike." print
 148     nl
 149     "'n' is a slot number in the following:" print
 150     nl
 151     "&back -- return to previous object" print
 152     "&push ( -- obj ) push this object" print
 153     "&at ( n -- ) inspect nth slot" print
 154     "&put ( value n -- ) change nth slot" print
 155     "&add ( value key -- ) add new slot" print
 156     "&delete ( n -- ) remove a slot" print
 157     "&rename ( key n -- ) change a slot's key" print
 158     "&help -- display this message" print
 159     nl ;
 160
 161 : inspector ( obj -- )
 162     &help
 163     V{ } clone inspector-stack set
 164     (inspect) ;
 165
 166 : inspect ( obj -- )
 167     inspector-stack get [ (inspect) ] [ inspector ] if ;