basis/inspector/inspector.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors 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 summary debugger continuations fry ;
   7 IN: inspector
   8
   9 : value-editor ( path -- )
  10     [
  11         [ pprint-short ] presented-printer set
  12         dup presented-path set
  13     ] H{ } make-assoc
  14     [ get-ref pprint-short ] with-nesting ;
  15
  16 SYMBOL: +sequence+
  17 SYMBOL: +number-rows+
  18 SYMBOL: +editable+
  19
  20 : write-slot-editor ( path -- )
  21     [
  22         +editable+ get [
  23             value-editor
  24         ] [
  25             get-ref pprint-short
  26         ] if
  27     ] with-cell ;
  28
  29 : write-key ( mirror key -- )
  30     +sequence+ get
  31     [ 2drop ] [ <key-ref> write-slot-editor ] if ;
  32
  33 : write-value ( mirror key -- )
  34     <value-ref> write-slot-editor ;
  35
  36 : describe-row ( mirror key n -- )
  37     [
  38         +number-rows+ get [ pprint-cell ] [ drop ] if
  39         [ write-key ] [ write-value ] 2bi
  40     ] with-row ;
  41
  42 : summary. ( obj -- ) [ summary ] keep write-object nl ;
  43
  44 : sorted-keys ( assoc -- alist )
  45     dup hashtable? [
  46         keys
  47         [ [ unparse-short ] keep ] { } map>assoc
  48         sort-keys values
  49     ] [ keys ] if ;
  50
  51 : describe* ( obj mirror keys -- )
  52     [ summary. ] 2dip
  53     [ drop ] [
  54         dup enum? [ +sequence+ on ] when
  55         standard-table-style [
  56             swap '[ [ _ ] 2dip describe-row ] each-index
  57         ] tabular-output
  58     ] if-empty ;
  59
  60 : describe ( obj -- )
  61     dup make-mirror dup sorted-keys describe* ;
  62
  63 M: tuple error. describe ;
  64
  65 : namestack. ( seq -- )
  66     [ [ global eq? not ] filter [ keys ] gather ] keep
  67     '[ dup _ assoc-stack ] H{ } map>assoc describe ;
  68
  69 : .vars ( -- )
  70     namestack namestack. ;
  71
  72 : :vars ( -- )
  73     error-continuation get name>> namestack. ;
  74
  75 SYMBOL: inspector-hook
  76
  77 [ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
  78
  79 SYMBOL: inspector-stack
  80
  81 SYMBOL: me
  82
  83 : reinspect ( obj -- )
  84     [ me set ]
  85     [
  86         dup make-mirror dup mirror set dup sorted-keys dup \ keys set
  87         inspector-hook get call
  88     ] bi ;
  89
  90 : (inspect) ( obj -- )
  91     [ inspector-stack get push ] [ reinspect ] bi ;
  92
  93 : key@ ( n -- key ) \ keys get nth ;
  94
  95 : &push ( -- obj ) me get ;
  96
  97 : &at ( n -- ) key@ mirror get at (inspect) ;
  98
  99 : &back ( -- )
 100     inspector-stack get
 101     dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
 102
 103 : &add ( value key -- ) mirror get set-at &push reinspect ;
 104
 105 : &put ( value n -- ) key@ &add ;
 106
 107 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
 108
 109 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
 110
 111 : &help ( -- )
 112     #! A tribute to Slate:
 113     "You are in a twisty little maze of objects, all alike." print
 114     nl
 115     "'n' is a slot number in the following:" print
 116     nl
 117     "&back -- return to previous object" print
 118     "&push ( -- obj ) push this object" print
 119     "&at ( n -- ) inspect nth slot" print
 120     "&put ( value n -- ) change nth slot" print
 121     "&add ( value key -- ) add new slot" print
 122     "&delete ( n -- ) remove a slot" print
 123     "&rename ( key n -- ) change a slot's key" print
 124     "&globals ( -- ) inspect global namespace" print
 125     "&help -- display this message" print
 126     nl ;
 127
 128 : inspector ( obj -- )
 129     &help
 130     V{ } clone inspector-stack set
 131     (inspect) ;
 132
 133 : inspect ( obj -- )
 134     inspector-stack get [ (inspect) ] [ inspector ] if ;
 135
 136 : &globals ( -- ) global inspect ;