core/ui/tools/operations.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-workspace
   4 USING: definitions gadgets gadgets-browser gadgets-dataflow
   5 gadgets-help gadgets-listener gadgets-search gadgets-text
   6 gadgets-workspace hashtables help inference kernel namespaces
   7 parser prettyprint scratchpad sequences strings styles syntax
   8 test tools words generic models io modules errors ;
   9
  10 V{ } clone operations set-global
  11
  12 SYMBOL: +name+
  13 SYMBOL: +quot+
  14 SYMBOL: +listener+
  15 SYMBOL: +keyboard+
  16 SYMBOL: +primary+
  17 SYMBOL: +secondary+
  18
  19 : (command) ( -- command )
  20     +name+ get +keyboard+ get +quot+ get <command> ;
  21
  22 C: operation ( predicate hash -- operation )
  23     swap [
  24         (command) over set-delegate
  25         +primary+ get over set-operation-primary?
  26         +secondary+ get over set-operation-secondary?
  27         +listener+ get over set-operation-listener?
  28     ] bind
  29     [ set-operation-predicate ] keep ;
  30
  31 M: operation invoke-command
  32     [ operation-hook call ] keep
  33     dup command-quot swap operation-listener?
  34     [ curry call-listener ] [ call ] if ;
  35
  36 : define-operation ( class props -- )
  37     <operation> operations get push ;
  38
  39 : modify-command ( quot command -- command )
  40     clone
  41     [ command-quot append ] keep
  42     [ set-command-quot ] keep ;
  43
  44 : modify-commands ( commands quot -- commands )
  45     swap [ modify-command ] map-with ;
  46
  47 : listener-operation ( hook quot operation -- operation )
  48     modify-command
  49     tuck set-operation-hook
  50     t over set-operation-listener? ;
  51
  52 : listener-operations ( operations hook quot -- operations )
  53     rot [ >r 2dup r> listener-operation ] map 2nip ;
  54
  55 ! Objects
  56 [ drop t ] H{
  57     { +primary+ t }
  58     { +name+ "Inspect" }
  59     { +quot+ [ inspect ] }
  60     { +listener+ t }
  61 } define-operation
  62
  63 [ drop t ] H{
  64     { +name+ "Prettyprint" }
  65     { +quot+ [ . ] }
  66     { +listener+ t }
  67 } define-operation
  68
  69 [ drop t ] H{
  70     { +name+ "Push" }
  71     { +quot+ [ ] }
  72     { +listener+ t }
  73 } define-operation
  74
  75 ! Input
  76 [ input? ] H{
  77     { +primary+ t }
  78     { +secondary+ t }
  79     { +name+ "Input" }
  80     { +quot+ [ listener-gadget call-tool ] }
  81 } define-operation
  82
  83 ! Restart
  84 [ restart? ] H{
  85     { +primary+ t }
  86     { +secondary+ t }
  87     { +name+ "Restart" }
  88     { +quot+ [ restart ] }
  89     { +listener+ t }
  90 } define-operation
  91
  92 ! Pathnames
  93 [ pathname? ] H{
  94     { +primary+ t }
  95     { +secondary+ t }
  96     { +name+ "Edit" }
  97     { +quot+ [ pathname-string edit-file ] }
  98 } define-operation
  99
 100 [ pathname? ] H{
 101     { +name+ "Run file" }
 102     { +keyboard+ T{ key-down f { A+ } "r" } }
 103     { +quot+ [ pathname-string run-file ] }
 104     { +listener+ t }
 105 } define-operation
 106
 107 ! Words
 108 [ word? ] H{
 109     { +primary+ t }
 110     { +name+ "Browse" }
 111     { +keyboard+ T{ key-down f { A+ } "b" } }
 112     { +quot+ [ browser call-tool ] }
 113 } define-operation
 114
 115 : word-completion-string ( word listener -- string )
 116     >r dup word-name swap word-vocabulary dup vocab r>
 117     listener-gadget-input interactor-use memq?
 118     [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
 119
 120 : insert-word ( word -- )
 121     get-listener [ word-completion-string ] keep
 122     listener-gadget-input user-input ;
 123
 124 [ word? ] H{
 125     { +secondary+ t }
 126     { +name+ "Insert" }
 127     { +quot+ [ insert-word ] }
 128 } define-operation
 129
 130 [ word? ] H{
 131     { +name+ "Edit" }
 132     { +keyboard+ T{ key-down f { A+ } "e" } }
 133     { +quot+ [ edit ] }
 134 } define-operation
 135
 136 [ word? ] H{
 137     { +name+ "Documentation" }
 138     { +keyboard+ T{ key-down f { A+ } "h" } }
 139     { +quot+ [ help-gadget call-tool ] }
 140 } define-operation
 141
 142 [ word? ] H{
 143     { +name+ "Usage" }
 144     { +keyboard+ T{ key-down f { A+ } "u" } }
 145     { +quot+ [ usage. ] }
 146     { +listener+ t }
 147 } define-operation
 148
 149 [ word? ] H{
 150     { +name+ "Reload" }
 151     { +keyboard+ T{ key-down f { A+ } "r" } }
 152     { +quot+ [ reload ] }
 153     { +listener+ t }
 154 } define-operation
 155
 156 [ word? ] H{
 157     { +name+ "Watch" }
 158     { +quot+ [ watch ] }
 159 } define-operation
 160
 161 [ word? ] H{
 162     { +name+ "Forget" }
 163     { +quot+ [ forget ] }
 164 } define-operation
 165
 166 [ compound? ] H{
 167     { +name+ "Word stack effect" }
 168     { +quot+ [ word-def infer. ] }
 169     { +listener+ t }
 170 } define-operation
 171
 172 [ compound? ] H{
 173     { +name+ "Word dataflow" }
 174     { +quot+ [ word-def show-dataflow ] }
 175     { +keyboard+ T{ key-down f { A+ } "d" } }
 176 } define-operation
 177
 178 ! Vocabularies
 179 [ vocab-link? ] H{
 180     { +primary+ t }
 181     { +name+ "Browse" }
 182     { +keyboard+ T{ key-down f { A+ } "b" } }
 183     { +quot+ [ vocab-link-name get-workspace swap show-vocab-words ] }
 184 } define-operation
 185
 186 [ vocab-link? ] H{
 187     { +name+ "Enter in" }
 188     { +keyboard+ T{ key-down f { A+ } "i" } }
 189     { +quot+ [ vocab-link-name set-in ] }
 190     { +listener+ t }
 191 } define-operation
 192
 193 [ vocab-link? ] H{
 194     { +secondary+ t }
 195     { +name+ "Use" }
 196     { +quot+ [ vocab-link-name use+ ] }
 197     { +listener+ t }
 198 } define-operation
 199
 200 [ vocab-link? ] H{
 201     { +name+ "Forget" }
 202     { +quot+ [ vocab-link-name forget-vocab ] }
 203 } define-operation
 204
 205 ! Modules
 206 [ module? ] H{
 207     { +secondary+ t }
 208     { +name+ "Run" }
 209     { +quot+ [ module-name run-module ] }
 210     { +listener+ t }
 211 } define-operation
 212
 213 [ module? ] H{
 214     { +name+ "Load" }
 215     { +quot+ [ module-name require ] }
 216     { +listener+ t }
 217 } define-operation
 218
 219 [ module? ] H{
 220     { +name+ "Documentation" }
 221     { +keyboard+ T{ key-down f { A+ } "h" } }
 222     { +quot+ [ module-help [ help-gadget call-tool ] when* ] }
 223 } define-operation
 224
 225 [ module? ] H{
 226     { +name+ "Edit" }
 227     { +keyboard+ T{ key-down f { A+ } "e" } }
 228     { +quot+ [ edit ] }
 229 } define-operation
 230
 231 [ module? ] H{
 232     { +primary+ t }
 233     { +name+ "Browse" }
 234     { +keyboard+ T{ key-down f { A+ } "b" } }
 235     { +quot+ [ get-workspace swap show-module-files ] }
 236 } define-operation
 237
 238 [ module? ] H{
 239     { +name+ "See" }
 240     { +quot+ [ browser call-tool ] }
 241 } define-operation
 242
 243 [ module? ] H{
 244     { +name+ "Test" }
 245     { +quot+ [ module-name test-module ] }
 246     { +listener+ t }
 247 } define-operation
 248
 249 ! Module links
 250 [ module-link? ] H{
 251     { +primary+ t }
 252     { +secondary+ t }
 253     { +name+ "Run" }
 254     { +quot+ [ module-name run-module ] }
 255     { +listener+ t }
 256 } define-operation
 257
 258 [ module-link? ] H{
 259     { +name+ "Load" }
 260     { +quot+ [ module-name require ] }
 261     { +listener+ t }
 262 } define-operation
 263
 264 ! Link
 265 [ link? ] H{
 266     { +primary+ t }
 267     { +secondary+ t }
 268     { +name+ "Follow" }
 269     { +quot+ [ help-gadget call-tool ] }
 270 } define-operation
 271
 272 [ link? ] H{
 273     { +name+ "Edit" }
 274     { +keyboard+ T{ key-down f { A+ } "e" } }
 275     { +quot+ [ edit ] }
 276 } define-operation
 277
 278 [ link? ] H{
 279     { +name+ "Reload" }
 280     { +keyboard+ T{ key-down f { A+ } "r" } }
 281     { +quot+ [ reload ] }
 282 } define-operation
 283
 284 [ word-link? ] H{
 285     { +name+ "Definition" }
 286     { +keyboard+ T{ key-down f { A+ } "b" } }
 287     { +quot+ [ link-name browser call-tool ] }
 288 } define-operation
 289
 290 ! Quotations
 291 [ quotation? ] H{
 292     { +name+ "Quotation stack effect" }
 293     { +keyboard+ T{ key-down f { C+ } "i" } }
 294     { +quot+ [ infer. ] }
 295     { +listener+ t }
 296 } define-operation
 297
 298 [ quotation? ] H{
 299     { +name+ "Quotation dataflow" }
 300     { +keyboard+ T{ key-down f { C+ } "d" } }
 301     { +quot+ [ show-dataflow ] }
 302     { +listener+ t }
 303 } define-operation
 304
 305 [ quotation? ] H{
 306     { +name+ "Walk" }
 307     { +keyboard+ T{ key-down f { C+ } "w" } }
 308     { +quot+ [ walk ] }
 309     { +listener+ t }
 310 } define-operation
 311
 312 [ quotation? ] H{
 313     { +name+ "Time" }
 314     { +keyboard+ T{ key-down f { C+ } "t" } }
 315     { +quot+ [ time ] }
 316     { +listener+ t }
 317 } define-operation
 318
 319 ! Dataflow nodes
 320 [ [ node? ] is? ] H{
 321     { +primary+ t }
 322     { +name+ "Show dataflow" }
 323     { +quot+ [ dataflow-gadget call-tool ] }
 324 } define-operation
 325
 326 ! Define commands in terms of operations
 327
 328 ! Interactor commands
 329 : quot-action ( interactor -- quot )
 330     dup editor-string swap select-all ;
 331
 332 interactor "words"
 333 { word compound } [ class-operations ] map concat
 334 [ selected-word ] [ search ] listener-operations
 335 define-commands
 336
 337 interactor "quotations"
 338 quotation class-operations
 339 [ quot-action ] [ parse ] listener-operations
 340 define-commands
 341
 342 help-gadget "toolbar" {
 343     { "Back" T{ key-down f { C+ } "b" } [ help-gadget-history go-back ] }
 344     { "Forward" T{ key-down f { C+ } "f" } [ help-gadget-history go-forward ] }
 345     { "Home" T{ key-down f { C+ } "1" } [ go-home ] }
 346 }
 347 link class-operations [ help-action ] modify-commands
 348 [ command-name "Follow" = not ] subset
 349 append
 350 define-commands