Add HOOK-CONSULT: to delegate

This allows for delegation of hooks and their associated singletons,
working around their inability to be subclassed.

diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor
index 0d8781ab8a1b190212da8120c9524ca0a2b05bc3..0c9a0dd9d753783d1d830a49d929aea6fd6d3af0 100644 (file)
--- a/basis/delegate/delegate-docs.factor
+++ b/basis/delegate/delegate-docs.factor
@@ -23,6 +23,12 @@ HELP: CONSULT:
 { $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 ;" }

diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index 8703736bee920792f6f547dde7cc3cd2b9041066..ab3a12b9ad8231e95e10b121af8b4b692b7ee5cb 100644 (file)
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -3,8 +3,8 @@
 ! 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 ;
@@ -44,6 +44,8 @@ M: tuple-class group-words
 
 TUPLE: consultation group class quot loc ;
 
+TUPLE: hook-consultation < consultation hook-var ;
+
 TUPLE: broadcast < consultation ;
 
 : <consultation> ( group class quot -- consultation )
@@ -52,6 +54,13 @@ TUPLE: broadcast < 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 ;
@@ -70,6 +79,9 @@ M: consultation (consult-method-quot)
 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
@@ -113,6 +125,10 @@ SYNTAX: CONSULT:
     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 ;

diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor
index 409307a7d1b4bdb4ca6cee13c84a6d3084bba99b..d4a62f49bea262805953c3c2f071e0ec639df59e 100644 (file)
--- a/basis/delegate/protocols/protocols.factor
+++ b/basis/delegate/protocols/protocols.factor
@@ -1,7 +1,7 @@
 ! 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
@@ -28,3 +28,30 @@ stream-readln stream-read-until stream-contents* ;
 
 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 ;