shen inspired function in red

pfn.red

Red []

;; https://gist.github.com/hiiamboris/5f85edba139fc88a5eb0ee9b7b30bc6b
arity?: function [p [word! path!]] [
	either word? p [
		preprocessor/func-arity? spec-of get :p
	][
		; path format: obj1/obj2.../func/ref1/ref2...
		; have to find a point where in that path a function starts
		; i.e. p2: obj1/obj2.../func
		; and the call itself is: func/ref1/ref2...
		p2: as path! clear head []		; reuse the same block over and over again
		until [
			append  p2  pick p 1 + length? p2
			; stupid get won't accept paths of single length like [change], have to work around
			any-function? get either 1 = length? p2 [p2/1][p2]
		]
		preprocessor/func-arity?/with  (spec-of get either 1 = length? p2 [p2/1][p2])  (at p length? p2)
	]
]

arity??: function [x][
    valid: all [value? x find [word! path!] type?/word x]
    either valid [arity? x][0]
]

first-expr-split: function [block [block!]][
    expr: copy/deep block
    ret: copy []
    step: function [][
        x: take expr
        ar: arity?? x
        append/only ret x
        while [ar > 0][step ar: ar - 1]
    ]
    also reduce [ret expr] step
]

; >> first-expr-split [append next [1 2 3] [4 5 6] append "hello" "world"]
; == [[append next [1 2 3] [4 5 6]] [append "hello" "world"]]

prevs: func [
    "prevs next next [1 2 3] => [1 2]"
    s [series!]
][
    copy/part copy head s (index? s) - 1
]

pfn: function [spec body][
    
    arity: length? spec
    body: copy/deep body
    cases: copy []

    until [
        p: find body '->
        rule: prevs p
        splitted: first-expr-split next p
        block: first splitted
        append cases reduce ['parse 'reduce spec rule block]
        body: second splitted
        tail? body
    ]

    func spec reduce ['case cases]
]

f: pfn [a b][
    2 integer! -> add a b
    'foo any-type! ->  'foooooooo...
    2 block! -> append/only copy next a b
    string! into [some integer!] -> do [print "pouet" 42]
    2 any-type! -> "blaz"
]

reduce [
    f 1 2 ; 3
    f 'foo 2 ; 'fooo...
    f [a b c] [b c d] ; [b c [b c d]]
    f "i" [1 2 3] ; prints "pouet"
    f 1.2.3 #() ; "blaz
]