1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit
4 combinators.smart definitions.icons fry kernel locals
5 math.order models models.search models.sort present see
6 sequences tools.profiler ui.baseline-alignment ui.commands
7 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
8 ui.gadgets.labeled ui.gadgets.labels ui.gadgets.packs
9 ui.gadgets.search-tables ui.gadgets.status-bar
10 ui.gadgets.tabbed ui.gadgets.tables ui.gadgets.tracks
11 ui.gestures ui.images ui.operations ui.tools.browser
12 ui.tools.common vocabs words ;
13 FROM: models.arrow => <arrow> ;
14 FROM: models.arrow.smart => <smart-arrow> ;
15 FROM: models.product => <product> ;
18 TUPLE: profiler-gadget < tool
25 SINGLETONS: word-renderer vocab-renderer ;
26 UNION: profiler-renderer word-renderer vocab-renderer ;
30 : with-datastack* ( seq quot -- seq' )
31 '[ _ input<sequence ] output>array ; inline
35 ! Value is a { word count } pair
36 M: profiler-renderer row-columns
40 [ [ definition-icon <image-name> ] [ present ] bi ]
44 ] [ { "" "All" "" } ] if* ;
46 M: profiler-renderer prototype-row
47 drop \ = definition-icon <image-name> "" "" 3array ;
49 M: profiler-renderer row-value
50 drop dup [ first ] when ;
52 M: profiler-renderer column-alignment drop { 0 0 1 } ;
53 M: profiler-renderer filled-column drop 1 ;
55 M: word-renderer column-titles drop { "" "Word" "Count" } ;
56 M: vocab-renderer column-titles drop { "" "Vocabulary" "Count" } ;
58 SINGLETON: method-renderer
60 M: method-renderer column-alignment drop { 0 0 1 } ;
61 M: method-renderer filled-column drop 1 ;
63 ! Value is a { method count } pair
64 M: method-renderer row-columns
66 [ [ definition-icon <image-name> ] [ synopsis ] bi ]
71 M: method-renderer row-value drop first ;
73 M: method-renderer column-titles drop { "" "Method" "Count" } ;
75 : <profiler-model> ( values profiler -- model )
76 [ [ filter-counts ] <arrow> ] [ sort>> ] bi* <sort> ;
78 : <words-model> ( profiler -- model )
80 [ words>> ] [ vocab>> ] bi
83 [ first vocabulary>> ]
88 ] keep <profiler-model> ;
90 : <profiler-table> ( model renderer -- table )
91 [ dup [ first present ] when ] <search-table>
92 [ invoke-primary-operation ] >>action ;
94 : <profiler-filter-model> ( counts profiler -- model' )
95 [ <model> ] dip <profiler-model> [ f prefix ] <arrow> ;
97 : <vocabs-model> ( profiler -- model )
98 [ vocab-counters [ [ vocab ] dip ] assoc-map ] dip
99 <profiler-filter-model> ;
101 : <generic-model> ( profiler -- model )
102 [ generic-counters ] dip <profiler-filter-model> ;
104 : <class-model> ( profiler -- model )
105 [ class-counters ] dip <profiler-filter-model> ;
107 : method-matches? ( method generic class -- ? )
110 [ drop dup [ subwords member-eq? ] [ 2drop t ] if ]
111 [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
114 : <methods-model> ( profiler -- model )
116 [ method-counters <model> ] dip
117 [ generic>> ] [ class>> ] bi
118 [ '[ _ _ method-matches? ] filter ] <smart-arrow>
119 ] keep <profiler-model> ;
121 : sort-by-name ( obj1 obj2 -- <=> )
122 [ first name>> ] compare ;
124 : sort-by-call-count ( obj1 obj2 -- <=> )
125 [ second ] compare invert-comparison ;
127 : sort-options ( -- alist )
129 { [ sort-by-name ] "by name" }
130 { [ sort-by-call-count ] "by call count" }
133 : <sort-options> ( model -- gadget )
137 "Sort by:" <label> add-gadget
138 swap sort-options <radio-buttons> horizontal >>orientation add-gadget ;
140 : <profiler-tool-bar> ( profiler -- gadget )
145 [ <toolbar> add-gadget ]
146 [ sort>> <sort-options> add-gadget ] bi ;
148 :: <words-tab> ( profiler -- gadget )
151 profiler vocabs>> vocab-renderer <profiler-table>
152 profiler vocab>> >>selection
155 "Vocabularies" <labeled-gadget>
157 profiler <words-model> word-renderer <profiler-table>
160 "Words" <labeled-gadget>
163 :: <methods-tab> ( profiler -- gadget )
168 profiler <generic-model> word-renderer <profiler-table>
169 profiler generic>> >>selection
170 "Generic words" <labeled-gadget>
172 profiler <class-model> word-renderer <profiler-table>
173 profiler class>> >>selection
174 "Classes" <labeled-gadget>
177 profiler methods>> method-renderer <profiler-table>
181 "Methods" <labeled-gadget>
184 : <selection-model> ( -- model ) { f 0 } <model> ;
186 : <profiler-gadget> ( -- profiler )
187 vertical profiler-gadget new-track
189 [ sort-by-name ] <model> >>sort
190 all-words counters <model> >>words
191 <selection-model> >>vocab
192 dup <vocabs-model> >>vocabs
193 <selection-model> >>generic
194 <selection-model> >>class
195 dup <methods-model> >>methods
196 dup <profiler-tool-bar> { 3 3 } <filled-border> f track-add
198 over <words-tab> "Words" add-tab
199 over <methods-tab> "Methods" add-tab
202 : profiler-help ( -- ) "ui-profiler" com-browse ;
204 \ profiler-help H{ { +nullary+ t } } define-command
206 profiler-gadget "toolbar" f {
207 { T{ key-down f f "F1" } profiler-help }
210 : profiler-window ( -- )
211 <profiler-gadget> "Profiling results" open-status-window ;
213 : com-profile ( quot -- ) profile profiler-window ; inline
215 MAIN: profiler-window