169 lines
5.0 KiB
Factor
169 lines
5.0 KiB
Factor
! Copyright (C) 2007, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel quotations accessors fry
|
|
assocs present math.order math.vectors arrays locals
|
|
models.search models.sort models sequences vocabs
|
|
tools.profiler words prettyprint ui ui.commands ui.gadgets
|
|
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
|
|
ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
|
|
ui.gadgets.labelled ui.gadgets.buttons ui.gadgets.packs
|
|
ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
|
|
ui.tools.browser ui.tools.common ;
|
|
FROM: models.filter => <filter> ;
|
|
FROM: models.compose => <compose> ;
|
|
IN: ui.tools.profiler
|
|
|
|
TUPLE: profiler-gadget < tool
|
|
sort
|
|
vocabs vocab
|
|
words
|
|
methods
|
|
generic class ;
|
|
|
|
{ 700 400 } profiler-gadget set-tool-dim
|
|
|
|
SINGLETONS: word-renderer vocab-renderer ;
|
|
UNION: profiler-renderer word-renderer vocab-renderer ;
|
|
|
|
! Value is a { word count } pair
|
|
M: profiler-renderer row-columns
|
|
drop [ [ present ] map ] [ { "All" "" } ] if* ;
|
|
|
|
M: profiler-renderer row-value
|
|
drop dup [ first ] when ;
|
|
|
|
M: vocab-renderer row-value
|
|
call-next-method dup [ vocab ] when ;
|
|
|
|
SINGLETON: method-renderer
|
|
|
|
! Value is a { method-body count } pair
|
|
M: method-renderer row-columns
|
|
drop [ first synopsis ] [ second present ] bi 2array ;
|
|
|
|
M: method-renderer row-value drop first ;
|
|
|
|
: <profiler-model> ( values profiler -- model )
|
|
[ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
|
|
|
|
: <words-model> ( profiler -- model )
|
|
[
|
|
[ words>> ] [ vocab>> ] bi
|
|
[
|
|
[
|
|
[ first vocabulary>> ]
|
|
[ vocab-name ]
|
|
bi* =
|
|
] when*
|
|
] <search>
|
|
] keep <profiler-model> ;
|
|
|
|
: match? ( pair/f str -- ? )
|
|
swap dup [ first present subseq? ] [ 2drop t ] if ;
|
|
|
|
: <profiler-table> ( model -- table )
|
|
[ match? ] <search-table>
|
|
{ 0 1 } >>column-alignment
|
|
0 >>filled-column ;
|
|
|
|
: <profiler-filter-model> ( counts profiler -- model' )
|
|
[ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
|
|
|
|
: <vocabs-model> ( profiler -- model )
|
|
[ vocab-counters ] dip <profiler-filter-model> ;
|
|
|
|
: <generic-model> ( profiler -- model )
|
|
[ generic-counters ] dip <profiler-filter-model> ;
|
|
|
|
: <class-model> ( profiler -- model )
|
|
[ class-counters ] dip <profiler-filter-model> ;
|
|
|
|
: method-matches? ( method generic class -- ? )
|
|
[ first ] 2dip
|
|
[ drop dup [ subwords memq? ] [ 2drop t ] if ]
|
|
[ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
|
|
3bi and ;
|
|
|
|
: <methods-model> ( profiler -- model )
|
|
[
|
|
[ method-counters <model> ] dip
|
|
[ generic>> ] [ class>> ] bi 3array <compose>
|
|
[ first3 '[ _ _ method-matches? ] filter ] <filter>
|
|
] keep <profiler-model> ;
|
|
|
|
: sort-options ( -- alist )
|
|
{
|
|
{ [ [ first ] compare ] "by name" }
|
|
{ [ [ second ] compare invert-comparison ] "by call count" }
|
|
} ;
|
|
|
|
: <sort-options> ( model -- gadget )
|
|
sort-options <radio-buttons> { 1 0 } >>orientation ;
|
|
|
|
: <profiler-tool-bar> ( profiler -- gadget )
|
|
<shelf>
|
|
{ 5 5 } >>gap
|
|
over <toolbar> add-gadget
|
|
"Sort by:" <label> add-gadget
|
|
swap sort>> <sort-options> add-gadget ;
|
|
|
|
:: <words-tab> ( profiler -- gadget )
|
|
{ 1 0 } <track>
|
|
profiler vocabs>> <profiler-table>
|
|
profiler vocab>> >>selected-value
|
|
vocab-renderer >>renderer
|
|
"Vocabularies" <labelled-gadget>
|
|
1/2 track-add
|
|
profiler <words-model> <profiler-table>
|
|
word-renderer >>renderer
|
|
"Words" <labelled-gadget>
|
|
1/2 track-add ;
|
|
|
|
:: <methods-tab> ( profiler -- gadget )
|
|
{ 0 1 } <track>
|
|
{ 1 0 } <track>
|
|
profiler <generic-model> <profiler-table>
|
|
profiler generic>> >>selected-value
|
|
word-renderer >>renderer
|
|
"Generic words" <labelled-gadget>
|
|
1/2 track-add
|
|
profiler <class-model> <profiler-table>
|
|
profiler class>> >>selected-value
|
|
word-renderer >>renderer
|
|
"Classes" <labelled-gadget>
|
|
1/2 track-add
|
|
1/2 track-add
|
|
profiler methods>> <profiler-table>
|
|
method-renderer >>renderer
|
|
"Methods" <labelled-gadget>
|
|
1/2 track-add ;
|
|
|
|
: <selection-model> ( -- model ) { f 0 } <model> ;
|
|
|
|
: <profiler-gadget> ( -- profiler )
|
|
{ 0 1 } profiler-gadget new-track
|
|
[ [ first ] compare ] <model> >>sort
|
|
all-words counters <model> >>words
|
|
<selection-model> >>vocab
|
|
dup <vocabs-model> >>vocabs
|
|
<selection-model> >>generic
|
|
<selection-model> >>class
|
|
dup <methods-model> >>methods
|
|
dup <profiler-tool-bar> f track-add
|
|
<tabbed-gadget>
|
|
over <words-tab> "Words" add-tab
|
|
over <methods-tab> "Methods" add-tab
|
|
1 track-add ;
|
|
|
|
: profiler-help ( -- ) "ui-profiler" com-follow ;
|
|
|
|
\ profiler-help H{ { +nullary+ t } } define-command
|
|
|
|
profiler-gadget "toolbar" f {
|
|
{ T{ key-down f f "F1" } profiler-help }
|
|
} define-command-map
|
|
|
|
: profiler-window ( -- )
|
|
<profiler-gadget> "Profiling results" open-status-window ;
|
|
|
|
MAIN: profiler-window |