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