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