diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 29f64efea3..3884da652a 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -6,24 +6,24 @@ classes.singleton classes.tuple classes.union combinators definitions effects fry generic help help.markup help.stylesheet help.topics io io.files io.pathnames io.styles kernel macros make namespaces prettyprint sequences sets sorting summary -tools.vocabs vocabs vocabs.loader words words.symbol ; +tools.vocabs vocabs vocabs.loader words words.symbol +combinators.smart definitions.icons ; IN: tools.vocabs.browser -: vocab-status-string ( vocab -- string ) - { - { [ dup vocab not ] [ drop "" ] } - { [ dup vocab-main ] [ drop "[Runnable]" ] } - [ drop "[Loaded]" ] - } cond ; +: <$definition> ( definition -- element ) + [ + [ definition-icon 1array \ $image prefix ] + [ drop " " ] + [ 1array \ $link prefix ] ! XXX + tri + ] output>array ; : vocab-row ( vocab -- row ) - [ <$link> ] [ vocab-status-string ] [ vocab-summary ] tri - 3array ; + [ <$definition> ] [ vocab-summary ] bi 2array ; : vocab-headings ( -- headings ) { { $strong "Vocabulary" } - { $strong "State" } { $strong "Summary" } } ; @@ -82,7 +82,7 @@ C: <vocab-author> vocab-author [ "Tuple classes" $subheading [ - [ <$link> ] + [ <$definition> ] [ superclass <$link> ] [ "slots" word-prop [ name>> ] map " " join <$snippet> ] tri 3array @@ -95,7 +95,7 @@ C: <vocab-author> vocab-author [ "Predicate classes" $subheading [ - [ <$link> ] + [ <$definition> ] [ superclass <$link> ] bi 2array ] map @@ -106,7 +106,7 @@ C: <vocab-author> vocab-author : (describe-classes) ( classes heading -- ) '[ _ $subheading - [ <$link> 1array ] map $table + [ <$definition> 1array ] map $table ] unless-empty ; : describe-builtin-classes ( classes -- ) @@ -158,14 +158,16 @@ C: <vocab-author> vocab-author $table ] unless-empty ; +: word-row ( word -- element ) + [ <$definition> ] + [ stack-effect dup [ effect>string <$snippet> ] when ] + bi 2array ; + +: word-headings ( -- element ) + { { $strong "Word" } { $strong "Stack effect" } } ; + : words-table ( words -- ) - [ - [ 1array \ $word-link prefix ] - [ stack-effect dup [ effect>string <$snippet> ] when ] - bi 2array - ] map - { { $strong "Word" } { $strong "Stack effect" } } prefix - $table ; + [ word-row ] map word-headings prefix $table ; : (describe-words) ( words heading -- ) '[ _ $subheading words-table ] unless-empty ; diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index f86166ffbc..563856ee9d 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs calendar colors colors.constants documents -documents.elements fry kernel words sets splitting math math.vectors -models.delay models.filter combinators.short-circuit parser present -sequences tools.completion tools.vocabs.browser generic -generic.standard.engines.tuple fonts ui.commands ui.operations -ui.gadgets ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers -ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labelled -ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures -ui.render ui.tools.listener.history combinators vocabs -ui.tools.listener.popups ; +USING: accessors arrays assocs calendar colors colors.constants +documents documents.elements fry kernel words sets splitting math +math.vectors models.delay models.filter combinators.short-circuit +parser present sequences tools.completion tools.vocabs.browser generic +generic.standard.engines.tuple fonts definitions.icons ui.images +ui.commands ui.operations ui.gadgets ui.gadgets.editors +ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables +ui.gadgets.tracks ui.gadgets.labelled ui.gadgets.theme +ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.render +ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots @@ -25,14 +25,17 @@ TUPLE: word-completion vocabs ; C: <word-completion> word-completion SINGLETONS: vocab-completion char-completion history-completion ; - -UNION: listener-completion word-completion vocab-completion char-completion history-completion ; +UNION: definition-completion word-completion vocab-completion ; +UNION: listener-completion definition-completion char-completion history-completion ; GENERIC: completion-quot ( interactor completion-mode -- quot ) -M: word-completion completion-quot 2drop [ [ { } ] [ words-matching ] if-empty ] ; -M: vocab-completion completion-quot 2drop [ [ { } ] [ vocabs-matching ] if-empty ] ; -M: char-completion completion-quot 2drop [ [ { } ] [ chars-matching ] if-empty ] ; +: (completion-quot) ( interactor completion-mode quot -- quot' ) + 2nip '[ [ { } ] _ if-empty ] ; inline + +M: word-completion completion-quot [ words-matching ] (completion-quot) ; +M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ; +M: char-completion completion-quot [ chars-matching ] (completion-quot) ; M: history-completion completion-quot drop '[ drop _ history-list ] ; GENERIC: completion-element ( completion-mode -- element ) @@ -55,6 +58,15 @@ M: history-completion completion-popup-width drop dim>> first ; ! Completion modes also implement the row renderer protocol M: listener-completion row-columns drop present 1array ; +M: definition-completion prototype-row + drop \ + definition-icon <image-name> "" 2array ; + +M: definition-completion row-columns + drop + [ definition-icon <image-name> ] + [ present ] bi + 2array ; + M: word-completion row-color [ vocabulary>> ] [ vocabs>> ] bi* { { [ 2dup [ vocab-words ] dip memq? ] [ COLOR: black ] } @@ -133,6 +145,8 @@ GENERIC# accept-completion-hook 1 ( item popup -- ) >>renderer monospace-font >>font t >>selection-required? + transparent >>column-line-color + 0 >>gap dup '[ _ accept-completion ] >>action ; : <completion-scroller> ( completion-popup -- scroller )