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