REBOL [ Title: "Overload" Date: 1-Mar-2025 Version: 1.0.1 File: %overload.r Author: Rights: "Annick ECUYER" Purpose: "Overloads an existing function/native." History: [ 28-Feb-2025 "Annick" {Initial version} 1-Mar-2025 "Annick" {Compatibility fix} ] Usage: { Overloads an existing function/native. Use "original*" to call the original function. Use "do redirect*" to call the original function with arguments/refinements. Examples: ; a simple copy of 'copy which shows the refinements used >> copy-2: overload :copy [] [do probe redirect*] >> copy-2/part "abc" 2 [original*/part :value :range] ; the redirection code == "ab" ; adds a /compress to 'save and /decompress to 'load ; -- any name could be used, but here the original 'save and 'load are replaced save: overload :save [/compress "Compresses data before saving it."] [ either compress [ write/binary where system/words/compress mold/all :value ] [do redirect*] ] load: overload :load [/decompress "Deompresses data at loading."] [ either decompress [ if any [file? :source url? source] [source: read/binary :source] source: as-binary :source load as-string system/words/decompress :source ] [do redirect*] ] ; save console history in a compressed binary file >> save/compress %history.bin system/console/history ; reload the saved console history >> system/console/history load/decompress %options.bin ; to recover the orginal 'save and 'load natives : >> new-save: :save >> new-load: :load >> save: overload/recover :save none none >> load: overload/recover :load none none ; or (will remove internal references) >> save: overload/purge :save none none >> load: overload/purge :load none none ; a new specification can be given instead of extending the original ; here we add string! as valid arguments to this 'add derivate function plus: overload/replace 'add [ "Returns the result of adding two values" value1 [string! number! pair! char! money! date! time! tuple!] value2 [string! number! pair! char! money! date! time! tuple!] ] [ either any [string? :value1 string? :value2] [ rejoin ["" :value1 "+" :value2] ] [original* :value1 :value2] ] ; overloading an overloaded function is blocked by default, use /force to bypass it. ; raises an error! >> plus2: overload :plus [] [probe reduce [value1 value2] do redirect*] ** User Error: Already an overload. Use /force to bypass. ** Near: overload :plus [] [probe reduce [value1 value2] do redirect*] ; ok >> plus2: overload/force :plus [] [probe reduce [value1 value2] do redirect*] } Notes: { ; The script returns the anonymous context where the 'overload function is defined : >> ctx-overload: do %overload.r It contains 'overloaded, a block with new-func [original-func] pairs. >> ctx-overload/overloaded } Exports: [overload] Library: [ level: 'advanced platform: 'all type: [function module] domain: [extension patch] tested-under: [ view 2.7.8.3.1 view 1.2.1.3.1 ] support: none license: 'MIT see-also: none ] ] context [ overloaded: copy [] set 'overload func [ [catch] {Overloads an existing function/native. Use "original*" to call the original function. Use "do redirect*" to call the original function with arguments/refinements. } function [any-function! word!] {Function to overload} new-spec [block! none!] {Specification extension.} new-body [block! none!] {New function body.} /replace {Replaces instead of extending the specification block} /force {Force the overload of an overloaded function} /recover {Returns the original function.} /purge {Removes the overload from the internal list and returns the original.} /local ctx arguments refinements refinement word ref-args ] [ if word? :function [function: get function] if purge [ either purge: select overloaded :function [ remove/part find overloaded :function 2 return first purge ] [return :function] ] if recover [ either recover: select overloaded :function [ return first recover ] [return :function] ] if all [ select overloaded :function not force ] [throw make error! "Already an overload. Use /force to bypass."] new-spec: append either replace [copy []] [ do mold copy/part third :function any [find third :function /local tail third :function] ] any [new-spec []] arguments: copy [] refinements: copy [] parse first :function [ any [set word word! (append arguments to-get-word word)] any [ set refinement refinement! (ref-args: copy []) any [ set word word! (append ref-args to-get-word word) ] (append refinements to-word refinement append/only refinements ref-args) ] ] if not find new-spec /local [append new-spec /local] ctx: context compose/deep [ original*: :function new*: func [(new-spec) redirect*] [ redirect*: func [/local argments func-refs] [ func-refs: copy [original*] arguments: copy [(arguments)] foreach [refinement arg-list] [(refinements)] [ if get refinement [append func-refs refinement append arguments arg-list] ] append reduce [to-path func-refs] arguments ] (any [new-body second :function]) ] ] append overloaded get in ctx 'new* append/only overloaded reduce [:function] get in ctx 'new* ] ]