1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel quotations accessors fry assocs present math.order
4 math.vectors arrays locals models.search models.sort models sequences
5 vocabs tools.profiler words prettyprint combinators.smart
6 definitions.icons ui ui.commands ui.gadgets ui.gadgets.panes
7 ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
8 ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
9 ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
10 ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
11 ui.tools.browser ui.tools.common ui.baseline-alignment
12 ui.operations ui.images ;
13 FROM: models.arrow => <arrow> ;
14 FROM: models.product => <product> ;
17 TUPLE: profiler-gadget < tool
24 SINGLETONS: word-renderer vocab-renderer ;
25 UNION: profiler-renderer word-renderer vocab-renderer ;
29 : with-datastack* ( seq quot -- seq' )
30 '[ _ input<sequence ] output>array ; inline
34 ! Value is a { word count } pair
35 M: profiler-renderer row-columns
39 [ [ definition-icon <image-name> ] [ present ] bi ]
43 ] [ { "" "All" "" } ] if* ;
45 M: profiler-renderer prototype-row
46 drop \ = definition-icon <image-name> "" "" 3array ;
48 M: profiler-renderer row-value
49 drop dup [ first ] when ;
51 M: profiler-renderer column-alignment drop { 0 0 1 } ;
52 M: profiler-renderer filled-column drop 1 ;
54 M: word-renderer column-titles drop { "" "Word" "Count" } ;
55 M: vocab-renderer column-titles drop { "" "Vocabulary" "Count" } ;
57 SINGLETON: method-renderer
59 M: method-renderer column-alignment drop { 0 0 1 } ;
60 M: method-renderer filled-column drop 1 ;
62 ! Value is a { method-body count } pair
63 M: method-renderer row-columns
65 [ [ definition-icon <image-name> ] [ synopsis ] bi ]
70 M: method-renderer row-value drop first ;
72 M: method-renderer column-titles drop { "" "Method" "Count" } ;
74 : <profiler-model> ( values profiler -- model )
75 [ [ filter-counts ] <arrow> ] [ sort>> ] bi* <sort> ;
77 : <words-model> ( profiler -- model )
79 [ words>> ] [ vocab>> ] bi
82 [ first vocabulary>> ]
87 ] keep <profiler-model> ;
89 : <profiler-table> ( model renderer -- table )
90 [ dup [ first present ] when ] <search-table>
91 [ invoke-primary-operation ] >>action ;
93 : <profiler-filter-model> ( counts profiler -- model' )
94 [ <model> ] dip <profiler-model> [ f prefix ] <arrow> ;
96 : <vocabs-model> ( profiler -- model )
97 [ vocab-counters [ [ vocab ] dip ] assoc-map ] dip
98 <profiler-filter-model> ;
100 : <generic-model> ( profiler -- model )
101 [ generic-counters ] dip <profiler-filter-model> ;
103 : <class-model> ( profiler -- model )
104 [ class-counters ] dip <profiler-filter-model> ;
106 : method-matches? ( method generic class -- ? )
108 [ drop dup [ subwords memq? ] [ 2drop t ] if ]
109 [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
112 : <methods-model> ( profiler -- model )
114 [ method-counters <model> ] dip
115 [ generic>> ] [ class>> ] bi 3array <product>
116 [ first3 '[ _ _ method-matches? ] filter ] <arrow>
117 ] keep <profiler-model> ;
119 : sort-by-name ( obj1 obj2 -- <=> )
120 [ first name>> ] compare ;
122 : sort-by-call-count ( obj1 obj2 -- <=> )
123 [ second ] compare invert-comparison ;
125 : sort-options ( -- alist )
127 { [ sort-by-name ] "by name" }
128 { [ sort-by-call-count ] "by call count" }
131 : <sort-options> ( model -- gadget )
135 "Sort by:" <label> add-gadget
136 swap sort-options <radio-buttons> horizontal >>orientation add-gadget ;
138 : <profiler-tool-bar> ( profiler -- gadget )
143 [ <toolbar> add-gadget ]
144 [ sort>> <sort-options> add-gadget ] bi ;
146 :: <words-tab> ( profiler -- gadget )
149 profiler vocabs>> vocab-renderer <profiler-table>
150 profiler vocab>> >>selected-value
153 "Vocabularies" <labeled-gadget>
155 profiler <words-model> word-renderer <profiler-table>
158 "Words" <labeled-gadget>
161 :: <methods-tab> ( profiler -- gadget )
166 profiler <generic-model> word-renderer <profiler-table>
167 profiler generic>> >>selected-value
168 "Generic words" <labeled-gadget>
170 profiler <class-model> word-renderer <profiler-table>
171 profiler class>> >>selected-value
172 "Classes" <labeled-gadget>
175 profiler methods>> method-renderer <profiler-table>
179 "Methods" <labeled-gadget>
182 : <selection-model> ( -- model ) { f 0 } <model> ;
184 : <profiler-gadget> ( -- profiler )
185 vertical profiler-gadget new-track
187 [ sort-by-name ] <model> >>sort
188 all-words counters <model> >>words
189 <selection-model> >>vocab
190 dup <vocabs-model> >>vocabs
191 <selection-model> >>generic
192 <selection-model> >>class
193 dup <methods-model> >>methods
194 dup <profiler-tool-bar> { 3 3 } <filled-border> f track-add
196 over <words-tab> "Words" add-tab
197 over <methods-tab> "Methods" add-tab
200 : profiler-help ( -- ) "ui-profiler" com-browse ;
202 \ profiler-help H{ { +nullary+ t } } define-command
204 profiler-gadget "toolbar" f {
205 { T{ key-down f f "F1" } profiler-help }
208 : profiler-window ( -- )
209 <profiler-gadget> "Profiling results" open-status-window ;
211 MAIN: profiler-window