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 ;
   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     rot summary.
  53     [
  54         drop
  55     ] [
  56         dup enum? [ +sequence+ on ] when
  57         standard-table-style [
  58             swap [ -rot describe-row ] curry each-index
  59         ] tabular-output
  60     ] if-empty ;
  61
  62 : describe ( obj -- )
  63     dup make-mirror dup sorted-keys describe* ;
  64
  65 M: tuple error. describe ;
  66
  67 : namestack. ( seq -- )
  68     [ [ global eq? not ] filter [ keys ] gather ] keep
  69     [ dupd assoc-stack ] curry H{ } map>assoc describe ;
  70
  71 : .vars ( -- )
  72     namestack namestack. ;
  73
  74 : :vars ( -- )
  75     error-continuation get name>> namestack. ;
  76
  77 SYMBOL: inspector-hook
  78
  79 [ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
  80
  81 SYMBOL: inspector-stack
  82
  83 SYMBOL: me
  84
  85 : reinspect ( obj -- )
  86     [ me set ]
  87     [
  88         dup make-mirror dup mirror set dup sorted-keys dup \ keys set
  89         inspector-hook get call
  90     ] bi ;
  91
  92 : (inspect) ( obj -- )
  93     [ inspector-stack get push ] [ reinspect ] bi ;
  94
  95 : key@ ( n -- key ) \ keys get nth ;
  96
  97 : &push ( -- obj ) me get ;
  98
  99 : &at ( n -- ) key@ mirror get at (inspect) ;
 100
 101 : &back ( -- )
 102     inspector-stack get
 103     dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
 104
 105 : &add ( value key -- ) mirror get set-at &push reinspect ;
 106
 107 : &put ( value n -- ) key@ &add ;
 108
 109 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
 110
 111 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
 112
 113 : &help ( -- )
 114     #! A tribute to Slate:
 115     "You are in a twisty little maze of objects, all alike." print
 116     nl
 117     "'n' is a slot number in the following:" print
 118     nl
 119     "&back -- return to previous object" print
 120     "&push ( -- obj ) push this object" print
 121     "&at ( n -- ) inspect nth slot" print
 122     "&put ( value n -- ) change nth slot" print
 123     "&add ( value key -- ) add new slot" print
 124     "&delete ( n -- ) remove a slot" print
 125     "&rename ( key n -- ) change a slot's key" print
 126     "&globals ( -- ) inspect global namespace" print
 127     "&help -- display this message" print
 128     nl ;
 129
 130 : inspector ( obj -- )
 131     &help
 132     V{ } clone inspector-stack set
 133     (inspect) ;
 134
 135 : inspect ( obj -- )
 136     inspector-stack get [ (inspect) ] [ inspector ] if ;
 137
 138 : &globals ( -- ) global inspect ;