core/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: arrays compiler gadgets gadgets-labels
   5 gadgets-panes gadgets-scrolling gadgets-text
   6 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 errors ;
  10
  11 TUPLE: listener-gadget input output stack ;
  12
  13 : ui-listener-hook ( listener -- )
  14     >r datastack r> listener-gadget-stack set-model ;
  15
  16 : ui-error-hook ( error listener -- )
  17     find-workspace dup workspace-error-hook call ;
  18
  19 : listener-stream ( listener -- stream )
  20     dup listener-gadget-input
  21     swap listener-gadget-output <pane-stream>
  22     <duplex-stream> ;
  23
  24 : <listener-input> ( -- gadget )
  25     gadget get listener-gadget-output
  26     <pane-stream> <interactor> ;
  27
  28 : <stack-display> ( -- gadget )
  29     gadget get listener-gadget-stack
  30     [ stack. ] "Stack" <labelled-pane> ;
  31
  32 : init-listener ( listener -- )
  33     f <model> swap set-listener-gadget-stack ;
  34
  35 : welcome. ( -- )
  36     "If this is your first time with Factor, please read " print
  37     "ui-tools" ($link) ", and especially " write
  38     "ui-listener" ($link) "." print terpri ;
  39
  40 : listener-thread ( listener -- )
  41     dup listener-stream [
  42         dup
  43         [ ui-listener-hook ] curry listener-hook set
  44         [ ui-error-hook ] curry error-hook set
  45         find-messages batch-errors set
  46         welcome.
  47         tty
  48     ] with-stream* ;
  49
  50 : start-listener ( listener -- )
  51     [ >r clear r> init-namespaces listener-thread ] in-thread
  52     drop ;
  53
  54 C: listener-gadget ( -- gadget )
  55     dup init-listener {
  56         {
  57             [ <scrolling-pane> ]
  58             set-listener-gadget-output
  59             [ <scroller> ]
  60             4/6
  61         }
  62         { [ <stack-display> ] f f 1/6 }
  63         {
  64             [ <listener-input> ]
  65             set-listener-gadget-input
  66             [ <scroller> "Input" <labelled-gadget> ]
  67             1/6
  68         }
  69     } { 0 1 } make-track* ;
  70
  71 M: listener-gadget focusable-child*
  72     listener-gadget-input ;
  73
  74 M: listener-gadget call-tool* ( input listener -- )
  75     >r input-string r> listener-gadget-input set-editor-string ;
  76
  77 M: listener-gadget tool-scroller
  78     listener-gadget-output find-scroller ;
  79
  80 M: listener-gadget tool-help
  81     drop "ui-listener" ;
  82
  83 : workspace-busy? ( workspace -- ? )
  84     listener-gadget swap find-tool nip tool-gadget
  85     listener-gadget-input interactor-busy? ;
  86
  87 : get-listener ( -- listener )
  88     listener-gadget
  89     [ workspace-busy? not ] get-workspace*
  90     show-tool tool-gadget ;
  91
  92 : (call-listener) ( quot listener -- )
  93     listener-gadget-input interactor-call ;
  94
  95 : call-listener ( quot -- )
  96     get-listener (call-listener) ;
  97
  98 : eval-listener ( string -- )
  99     get-listener
 100     listener-gadget-input [ set-editor-string ] keep
 101     interactor-commit ;
 102
 103 : listener-run-files ( seq -- )
 104     dup empty? [
 105         drop
 106     ] [
 107         [ run-files recompile ] curry call-listener
 108     ] if ;
 109
 110 : listener-eof ( listener -- )
 111     listener-gadget-input interactor-eof ;
 112
 113 : clear-listener-output ( listener -- )
 114     [ listener-gadget-output [ pane-clear ] curry ] keep
 115     (call-listener) ;
 116
 117 : clear-listener-stack ( listener -- )
 118     [ clear ] swap (call-listener) ;
 119
 120 listener-gadget "toolbar" {
 121     { "Restart" f [ start-listener ] }
 122     {
 123         "Clear output"
 124         T{ key-down f f "CLEAR" }
 125         [ clear-listener-output ]
 126     }
 127     {
 128         "Clear stack"
 129         T{ key-down f { C+ } "CLEAR" }
 130         [ clear-listener-stack ]
 131     }
 132     { "Send EOF" f [ listener-eof ] }
 133 } define-commands
 134
 135 debugger "toolbar" {
 136     { "Data stack" T{ key-down f f "s" } [ :s ] }
 137     { "Retain stack" T{ key-down f f "r" } [ :r ] }
 138     { "Call stack" T{ key-down f f "c" } [ :c ] }
 139     { "Help" T{ key-down f f "h" } [ :help ] }
 140     { "Edit" T{ key-down f f "e" } [ :edit ] }
 141 } [
 142     first3 [ call-listener drop ] curry 3array
 143 ] map define-commands