basis/inspector/inspector.factor

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