basis/inspector/inspector.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs continuations debugger fry hashtables io
   4 io.styles kernel math mirrors namespaces prettyprint
   5 prettyprint.custom prettyprint.sections sequences sets sorting
   6 summary ;
   7 IN: inspector
   8
   9 SYMBOL: +number-rows+
  10
  11 : print-summary ( obj -- )
  12     [ safe-summary ] keep write-object ;
  13
  14 <PRIVATE
  15
  16 : sort-unparsed-keys ( assoc -- alist )
  17     >alist dup keys
  18     [ unparse-short ] map
  19     zip sort-values keys ;
  20
  21 GENERIC: add-numbers ( alist -- table' )
  22
  23 M: enum add-numbers ;
  24
  25 M: assoc add-numbers
  26     +number-rows+ get [ [ prefix ] map-index ] when ;
  27
  28 TUPLE: slot-name name ;
  29
  30 M: slot-name pprint* name>> text ;
  31
  32 GENERIC: fix-slot-names ( assoc -- assoc )
  33
  34 M: assoc fix-slot-names >alist ;
  35
  36 M: mirror fix-slot-names
  37     [ [ slot-name boa ] dip ] { } assoc-map-as ;
  38
  39 : (describe) ( obj assoc -- keys )
  40     t pprint-string-cells? [
  41         [ print-summary nl ] [
  42             dup hashtable? [ sort-unparsed-keys ] when
  43             [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
  44         ] bi*
  45     ] with-variable ;
  46
  47 PRIVATE>
  48
  49 : describe ( obj -- ) dup make-mirror (describe) drop ;
  50
  51 M: tuple error. describe ;
  52
  53 : vars-in-scope ( seq -- alist )
  54     [ [ global eq? ] reject [ keys ] gather ] keep
  55     '[ dup _ assoc-stack ] H{ } map>assoc ;
  56
  57 : .vars ( -- )
  58     get-namestack vars-in-scope describe ;
  59
  60 : :vars ( -- )
  61     error-continuation get name>> vars-in-scope describe ;
  62
  63 SYMBOL: me
  64
  65 <PRIVATE
  66
  67 SYMBOL: inspector-stack
  68
  69 SYMBOL: sorted-keys
  70
  71 : reinspect ( obj -- )
  72     [ me set ]
  73     [
  74         dup make-mirror dup mirror set
  75         t +number-rows+ [ (describe) ] with-variable
  76         sorted-keys set
  77     ] bi ;
  78
  79 : (inspect) ( obj -- )
  80     [ inspector-stack get push ] [ reinspect ] bi ;
  81
  82 PRIVATE>
  83
  84 : key@ ( n -- key ) sorted-keys get nth ;
  85
  86 : &push ( -- obj ) me get ;
  87
  88 : &at ( n -- ) key@ mirror get at (inspect) ;
  89
  90 : &back ( -- )
  91     inspector-stack get
  92     dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ;
  93
  94 : &add ( value key -- ) mirror get set-at &push reinspect ;
  95
  96 : &put ( value n -- ) key@ &add ;
  97
  98 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
  99
 100 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
 101
 102 : &help ( -- )
 103     ! A tribute to Slate:
 104     "You are in a twisty little maze of objects, all alike." print
 105     nl
 106     "'n' is a slot number in the following:" print
 107     nl
 108     "&back -- return to previous object" print
 109     "&push ( -- obj ) push this object" print
 110     "&at ( n -- ) inspect nth slot" print
 111     "&put ( value n -- ) change nth slot" print
 112     "&add ( value key -- ) add new slot" print
 113     "&delete ( n -- ) remove a slot" print
 114     "&rename ( key n -- ) change a slot's key" print
 115     "&globals ( -- ) inspect global namespace" print
 116     "&help -- display this message" print
 117     nl ;
 118
 119 : inspector ( obj -- )
 120     &help
 121     V{ } clone inspector-stack set
 122     (inspect) ;
 123
 124 : inspect ( obj -- )
 125     inspector-stack get [ (inspect) ] [ inspector ] if ;
 126
 127 : &globals ( -- ) global inspect ;