Archive version of: overload.r ... version: 1 ... vincentecuye 28-Feb

Amendment note: new script || Publicly available? Yes

REBOL [
    Title: "Overload"
    Date: 28-Feb-2025
    Version: 1.0.0
    File: %overload.r
    Author: Rights: "Annick ECUYER"
    Purpose: "Overloads an existing function/native."
    History: [
        28-Feb-2025 "Annick" {Initial version}
    ]
	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] 
        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 []] [
            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*
    ]
]