library/ui/tools/listener.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-listener
   4 USING: compiler arrays gadgets gadgets-frames gadgets-labels
   5 gadgets-panes gadgets-scrolling gadgets-text gadgets-lists
   6 gadgets-search gadgets-theme gadgets-tracks gadgets-workspace
   7 generic hashtables tools io kernel listener math models
   8 namespaces parser prettyprint sequences shells strings styles
   9 threads words definitions help ;
  10
  11 TUPLE: listener-gadget input output stack use minibuffer ;
  12
  13 : ui-listener-hook ( listener -- )
  14     use get over set-listener-gadget-use
  15     >r datastack r> listener-gadget-stack set-model ;
  16
  17 : listener-stream ( listener -- stream )
  18     dup listener-gadget-input
  19     swap listener-gadget-output <pane-stream>
  20     <duplex-stream> ;
  21
  22 : <listener-input> ( -- gadget )
  23     gadget get listener-gadget-output
  24     <pane-stream> <interactor> ;
  25
  26 : <stack-display> ( -- gadget )
  27     gadget get listener-gadget-stack
  28     [ stack. ] "Stack" <labelled-pane> ;
  29
  30 : init-listener ( listener -- )
  31     f <model> swap set-listener-gadget-stack ;
  32
  33 : welcome. ( -- )
  34     "If this is your first time with Factor, please read " print
  35     "ui-tools" ($link) ", and especially " write
  36     "ui-listener" ($link) "." print terpri ;
  37
  38 : listener-thread ( listener -- )
  39     dup listener-stream [
  40         [ ui-listener-hook ] curry listener-hook set
  41         find-messages batch-errors set
  42         welcome.
  43         tty
  44     ] with-stream* ;
  45
  46 : start-listener ( listener -- )
  47     [ >r clear r> init-namespaces listener-thread ] in-thread
  48     drop ;
  49
  50 C: listener-gadget ( -- gadget )
  51     dup init-listener {
  52         {
  53             [ <scrolling-pane> ]
  54             set-listener-gadget-output
  55             [ <scroller> ]
  56             4/6
  57         }
  58         { [ <stack-display> ] f f 1/6 }
  59         {
  60             [ <listener-input> ]
  61             set-listener-gadget-input
  62             [ <scroller> "Input" <labelled-gadget> ]
  63             1/6
  64         }
  65     } { 0 1 } make-track* ;
  66
  67 M: listener-gadget focusable-child*
  68     listener-gadget-input ;
  69
  70 M: listener-gadget call-tool* ( input listener -- )
  71     >r input-string r> listener-gadget-input set-editor-text ;
  72
  73 M: listener-gadget tool-scroller
  74     listener-gadget-output find-scroller ;
  75
  76 M: listener-gadget tool-help
  77     drop "ui-listener" ;
  78
  79 : find-listener ( -- listener )
  80     listener-gadget find-workspace show-tool tool-gadget ;
  81
  82 : (call-listener) ( quot listener -- )
  83     listener-gadget-input interactor-call ;
  84
  85 : call-listener ( quot -- )
  86     find-listener (call-listener) ;
  87
  88 : listener-run-files ( seq -- )
  89     dup empty? [
  90         drop
  91     ] [
  92         [ [ run-file ] each ] curry call-listener
  93     ] if ;
  94
  95 : listener-eof ( listener -- )
  96     listener-gadget-input f swap interactor-eval ;
  97
  98 : clear-listener-output ( listener -- )
  99     [ listener-gadget-output [ pane-clear ] curry ] keep
 100     (call-listener) ;
 101
 102 : clear-listener-stack ( listener -- )
 103     [ clear ] swap (call-listener) ;
 104
 105 : hide-minibuffer ( listener -- )
 106     dup listener-gadget-minibuffer dup
 107     [ over track-remove ] [ drop ] if
 108     dup listener-gadget-input request-focus
 109     f swap set-listener-gadget-minibuffer ;
 110
 111 : show-minibuffer ( gadget listener -- )
 112     [ hide-minibuffer ] keep
 113     [ set-listener-gadget-minibuffer ] 2keep
 114     dupd track-add request-focus ;
 115
 116 : minibuffer-action ( quot -- quot )
 117     [ find-listener hide-minibuffer ] swap append ;
 118
 119 : show-word-search ( listener action -- )
 120     minibuffer-action
 121     >r dup listener-gadget-input selected-word r>
 122     <word-search> "Word search" <labelled-gadget>
 123     swap show-minibuffer ;
 124
 125 : show-source-files-search ( listener action -- )
 126     minibuffer-action
 127     "" swap <source-files-search>
 128     "Source file search" <labelled-gadget>
 129     swap show-minibuffer ;
 130
 131 : show-vocabs-search ( listener action -- )
 132     minibuffer-action
 133     >r dup listener-gadget-input selected-word r>
 134     <vocabs-search> "Vocabulary search" <labelled-gadget>
 135     swap show-minibuffer ;
 136
 137 : listener-history ( listener -- seq )
 138     listener-gadget-input interactor-history <reversed> ;
 139
 140 : history-action ( string -- )
 141     find-listener listener-gadget-input set-editor-text ;
 142
 143 : <history-gadget> ( listener -- gadget )
 144     listener-history <model>
 145     [ [ dup print-input ] make-pane ]
 146     [ history-action ] minibuffer-action
 147     <list> <scroller> "History" <labelled-gadget> ;
 148
 149 : show-history ( listener -- )
 150     [ <history-gadget> ] keep show-minibuffer ;
 151
 152 : insert-completion ( completion -- )
 153     word-name find-listener listener-gadget-input user-input ;
 154
 155 listener-gadget "toolbar" {
 156     { "Restart" T{ key-down f { C+ } "r" } [ start-listener ] }
 157     {
 158         "History"
 159         T{ key-down f { C+ } "h" }
 160         [ show-history ]
 161     }
 162     {
 163         "Clear output"
 164         T{ key-down f f "CLEAR" }
 165         [ clear-listener-output ]
 166     }
 167     {
 168         "Clear stack"
 169         T{ key-down f { C+ } "CLEAR" }
 170         [ clear-listener-stack ]
 171     }
 172     { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
 173 } define-commands
 174
 175 listener-gadget "completion" {
 176     {
 177         "Complete word"
 178         T{ key-down f f "TAB" }
 179         [ [ insert-completion ] show-word-search ]
 180     }
 181     {
 182         "Edit file"
 183         T{ key-down f { C+ } "e" }
 184         [ [ edit-file ] show-source-files-search ]
 185     }
 186     {
 187         "Use vocabulary"
 188         T{ key-down f { C+ } "u" }
 189         [ [ [ use+ ] curry call-listener ] show-vocabs-search ]
 190     }
 191     {
 192         "Hide minibuffer"
 193         T{ key-down f f "ESCAPE" }
 194         [ hide-minibuffer ]
 195     }
 196 } define-commands