Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
289 lines (270 sloc) 7.8 KB
Red[
Title: "Various function! related tools"
Author: "Boleslav Březovský"
Note: {
For details about these functions, see my articles:
`apply`, `ufc` - http://red.qyz.cz/apply-and-ufcs.html
`dispatcher` - http://red.qyz.cz/pattern-matching.html
}
]
actions: has [
"Return block of all actions"
result
][
result: []
if empty? result [
result: collect [
foreach word words-of system/words [
if action? get/any word [keep word]
]
]
]
result
]
op: func [
"Defines op! with given spec and body"
spec [block!]
body [block!]
][
make op! func spec body
]
; --- get arity and refinements ------------------------------------------------
arity?: func [
"Return function's arity" ; TODO: support for lit-word! and get-word! ?
fn [any-function!] "Function to examine"
/local result count name count-rule refinement-rule append-name
][
result: copy []
count: 0
name: none
append-name: quote (repend result either name [[name count]][[count]])
count-rule: [
some [
word! (count: count + 1)
| ahead refinement! refinement-rule
| skip
]
]
refinement-rule: [
append-name
set name refinement!
(count: 0)
count-rule
]
parse spec-of :fn count-rule
do append-name
either find result /local [
head remove/part find result /local 2
][result]
]
refinements?: func [
"Return block of refinements for given function"
fn [any-function!] "Function to examine"
/local value
][
parse spec-of :fn [
collect [some [set value refinement! keep (to word! value) | skip]]
]
]
; --- unified function call syntax ---------------------------------------------
ufcs: func [
"Apply functions to given series"
series [series!] "Series to manipulate"
dialect [block!] "Block of actions and arguments, without first argument (series defined above)"
/local result action args code arity refs ref-stack refs?
][
result: none
code: []
until [
; do some preparation
clear code
action: take dialect
arity: arity? get action
args: arity/1 - 1
refs: refinements? get action
ref-stack: clear []
refs?: false
unless zero? args [append ref-stack take dialect]
; check for refinements
while [find refs first dialect][
refs?: true
ref: take dialect
either path? action [
append action ref
][
action: make path! reduce [action ref]
]
unless zero? select arity ref [
append ref-stack take dialect
]
]
; put all code together
append/only code action
append/only code series
unless empty? ref-stack [append code ref-stack]
series: do code
empty? dialect
]
series
]
ufc: function [
"Apply functions to given series"
data [series!] "Series to manipulate"
dialect [block!] "Block of actions and arguments, without first argument (series defined above)"
][
foreach [cmd args] dialect [
data: apply get cmd head insert/only args data
]
data
]
; --- apply function -----------------------------------------------------------
apply: func [
"Apply a function to a block of arguments"
fn [any-function!] "Function value to apply"
args [block!] "Block of arguments (to quote refinement use QUOTE keyword)"
/local refs vals val
][
refs: copy []
vals: copy []
set-val: [set val skip (append/only vals val)]
parse args [
some [
'quote set-val
| set val refinement! (append refs to word! val)
| set-val
]
]
do compose [(make path! head insert refs 'fn) (vals)]
]
map: func [
"Apply code over block of values"
data
code
/local f
][
data: copy data
f: get take code
forall data [
data/1: apply :f compose [(first data) (code)]
]
data
]
map-each: func [
'word
series
code
][
collect [
until [
set :word first series
keep do code
series: next series
tail? series
]
]
]
; --- dispatch function --------------------------------------------------------
dispatcher: func [
"Return dispatcher function that can be extended with DISPATCH"
spec [block!] "Function specification"
][
func spec [
case []
]
]
dispatch: func [
"Add new condition and action to DISPATCHER function"
dispatcher [any-function!] "Dispatcher function to use"
cond [block! none!] "Block of conditions to pass or NONE for catch-all condition (forces /RELAX)"
body [block! none!] "Action to do when condition is fulfilled or NONE for removing rule"
/relax "Add condition to end of rules instead of beginning"
/local this cases mark penultimo
][
cases: second body-of :dispatcher
penultimo: back back tail cases
unless equal? true first penultimo [penultimo: tail cases]
if cond [bind cond :dispatcher]
if body [bind body :dispatcher]
this: compose/deep [all [(cond)] [(body)]]
case [
all [not cond not body not empty? penultimo][remove/part penultimo 2] ; remove catch-all rule (if exists)
all [not body mark: find/only cases cond][remove/part back mark 3] ; remove rule (if exists)
all [not cond true = first penultimo][change/only next penultimo body] ; change catch-all rule (if exists)
not cond [repend cases [true body]] ; add catch-all rule
mark: find/only cases cond [change/part back mark this 3] ; change existing rule (if exists)
relax [insert penultimo this] ; add new rule to end
'default [insert cases this] ; add new rule to beginning
]
:dispatcher
]
; --- function constructors --------------------------------------------
dfunc: func [
"Define function with default values for local words"
spec
body
][
; format for default values is [set-word: value] after /local refinement
; it's possible to mix normal words (without default value) and set-words
local: copy []
locals: copy #()
if mark: find spec /local [
parse next mark [
some [
set word set-word!
set value skip (
append local to word! word
locals/:word: value
)
| set word word! (append local word)
]
]
remove/part mark length? mark
append spec compose [/local (local)]
foreach word words-of locals [
insert body reduce [to set-word! word locals/:word]
]
]
func spec body
]
fce: func [
"The ultimate function constructor" ; right now supports /local only
spec [block!]
body [block!]
/local local-mark locals locs expose? body-rule word length
][
; get local words defined in function specs
parse spec [
any [
ahead /local local-mark: skip
copy locals to [refinement! | issue! | end]
| remove #expose (expose?: true)
| skip
]
]
unless locals [locals: copy []]
locs: clear []
; get local words defined in function body using local
parse body body-rule: [
some [
ahead [/local [set-word! | word!]]
remove skip set word skip (append locs to word! word)
| ['foreach | 'remove-each] set word [word! | block!] (append locs word)
| 'repeat set word word! (append locs word)
| ahead [block! | paren!] into body-rule
| skip
]
]
length: length? locals
either expose? [
remove/part local-mark 1 + length
][
append locals locs
locals: unique locals
either local-mark [
change/part next local-mark locals length
][
append spec head insert locals /local
]
]
func spec body
]