{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "code" "code to get the object to which the method should be forwarded" } }
{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing " { $snippet "code" } " with the original object as an input. " { $snippet "CONSULT:" } " will overwrite any existing methods on " { $snippet "class" } " for the members of " { $snippet "group" } ", but new methods can be added after the " { $snippet "CONSULT:" } " to override the delegation." } ;
+HELP: HOOK-CONSULT:
+{ $syntax "HOOK-CONSULT: group class var
+ code ;" }
+{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "var" "a variable" } { "code" "code to get the object to which the method should be forwarded" } }
+{ $description "Declares that objects of " { $snippet "class" } " will delegate the generic words contained in " { $snippet "group" } " to the object returned by executing the same word but with " { $snippet "var" } " re-bound to the value produced by" { $snippet "code" } ". It is your responsibility to ensure that the correct " { $snippet "var" } " is named, and that the code produces a value which can be stored in that " { $snippet "var" } "." } ;
+
HELP: BROADCAST:
{ $syntax "BROADCAST: group class
code ;" }
! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple
compiler.units definitions effects fry generic generic.standard
-hashtables kernel lexer make math parser sequences sets slots
-words words.symbol ;
+hashtables kernel lexer make math namespaces parser sequences
+sets slots words words.symbol ;
IN: delegate
ERROR: broadcast-words-must-have-no-outputs group ;
TUPLE: consultation group class quot loc ;
+TUPLE: hook-consultation < consultation hook-var ;
+
TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
: <broadcast> ( group class quot -- consultation )
[ check-broadcast-group ] 2dip f broadcast boa ;
+:: <hook-consultation> ( group class var quot -- hook-consultation )
+ hook-consultation new
+ group >>group
+ class >>class
+ quot >>quot
+ var >>hook-var ;
+
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep
[ drop ] [ "consultation" set-word-prop ] 2bi ;
M: broadcast (consult-method-quot)
'[ _ call [ _ execute ] each ] nip ;
+M:: hook-consultation (consult-method-quot) ( consultation quot word -- object )
+ [ quot call consultation hook-var>> [ word execute ] with-variable ] ;
+
: consult-method-quot ( consultation word -- object )
[ dup quot>> ] dip
[ second [ [ dip ] curry ] times ] [ first ] bi
scan-word scan-word parse-definition <consultation>
[ save-location ] [ define-consult ] bi ;
+SYNTAX: HOOK-CONSULT:
+ scan-word scan-word scan-word parse-definition <hook-consultation>
+ [ save-location ] [ define-consult ] bi ;
+
SYNTAX: BROADCAST:
scan-word scan-word parse-definition <broadcast>
[ save-location ] [ define-consult ] bi ;
! Copyright (C) 2007 Daniel Ehrenberg
! See https://factorcode.org/license.txt for BSD license.
USING: assocs delegate deques io sequences sequences.private
-sets ;
+sets ui.theme ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-nl ;
+
+PROTOCOL: theme-protocol
+toolbar-background toolbar-button-pressed-background
+menu-background menu-border-color status-bar-background
+status-bar-foreground button-text-color
+button-clicked-text-color line-color column-title-background
+roll-button-rollover-border roll-button-selected-background
+source-files-color errors-color details-color debugger-color
+completion-color data-stack-color retain-stack-color
+call-stack-color title-bar-gradient popup-color object-color
+contents-color help-header-background
+thread-status-stopped-background
+thread-status-suspended-background
+thread-status-running-background
+thread-status-stopped-foreground
+thread-status-suspended-foreground
+thread-status-running-foreground error-summary-background
+content-background text-color link-color title-color
+heading-color snippet-color output-color
+deprecated-background-color deprecated-border-color
+warning-background-color warning-border-color
+code-background-color code-border-color help-path-border-color
+tip-background-color prompt-background-color dim-color
+highlighted-word-color string-color stack-effect-color
+vocab-background-color vocab-border-color field-border-color
+editor-caret-color selection-color panel-background-color
+focus-border-color labeled-border-color table-border-color ;