core/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 ( obj key n -- )
  37     [
  38         +number-rows+ get [ pprint-cell ] [ drop ] if
  39         2dup write-key write-value
  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 flags -- )
  52     clone [
  53         dup summary.
  54         make-mirror dup sorted-keys dup empty? [
  55             2drop
  56         ] [
  57             dup enum? [ +sequence+ on ] when
  58             standard-table-style [
  59                 dup length
  60                 rot [ -rot describe-row ] curry 2each
  61             ] tabular-output
  62         ] if
  63     ] bind ;
  64
  65 : describe ( obj -- ) H{ } describe* ;
  66
  67 M: tuple error. describe ;
  68
  69 : namestack. ( seq -- )
  70     [ [ global eq? not ] filter [ keys ] gather ] keep
  71     [ dupd assoc-stack ] curry H{ } map>assoc describe ;
  72
  73 : .vars ( -- )
  74     namestack namestack. ;
  75
  76 : :vars ( -- )
  77     error-continuation get continuation-name namestack. ;
  78
  79 SYMBOL: inspector-hook
  80
  81 [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
  82
  83 SYMBOL: inspector-stack
  84
  85 SYMBOL: me
  86
  87 : reinspect ( obj -- )
  88     dup me set
  89     dup make-mirror dup mirror set keys \ keys set
  90     inspector-hook get call ;
  91
  92 : (inspect) ( obj -- )
  93     dup inspector-stack get push reinspect ;
  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     "&help -- display this message" print
 127     nl ;
 128
 129 : inspector ( obj -- )
 130     &help
 131     V{ } clone inspector-stack set
 132     (inspect) ;
 133
 134 : inspect ( obj -- )
 135     inspector-stack get [ (inspect) ] [ inspector ] if ;