Typed multiple dispatch in Red, per CLOS and PMD chat.

typed-multiple-dispatch.red

Red []

collect-values: func [
	"Collect values in a block, by datatype or custom parse rule"
	block [block!]
	rule  "Datatype, prototype value, or parse rule"
	/deep "Include nested blocks"
][
	rule: switch/default type?/word rule [
		datatype! block! typeset! [rule]			; Blocks and typesets (e.g. any-word!) work directly as rules.
	][ reduce [type? rule] ]						; Turn a prototype value into a rule for that value's type.

	; If they didn't spec /deep, any-block! skips nested blocks.
	; /deep does *not* look into nested path or string values.
	;!! We need good examples for `parse into` and its limitations.
	deep: either deep [
		[any-path! | any-string! | into top-rule]	; Don't parse into nested paths or strings
	][any-block!]									; any-block! skips nested blocks

	parse block top-rule: [
		collect any [keep rule | deep | skip]
	]
]

dispatch-ctx: context [
	table: #()

	set 'add-dispatch-func function [
		"Make a new dispatched function, to be called with `dispatch`"
		name spec body /ahead
	][
		if none? table/:name [table/:name: copy []]
		fn: func spec body
		; Get just block values from the spec, as those are the type defs
		; TBD: refinement handling and mutiple types per block (need to add | for parse matching)
		entry: reduce [collect-values spec block!  :fn]
		either ahead [
			insert table/:name entry
		][
			append table/:name entry
		]
		print mold table
	]

	set 'dispatch function [name args /local res][
		if table/:name [
			foreach [spec fn] table/:name [
				if parse args spec [
					print [name "match!" "spec:" mold spec "args:" mold args]
					set/any 'res do head insert copy args :fn
					break
				]
			]
			get/any 'res
		]
	]

]

add-dispatch-func 'fn-a [x [number!] y [number!]]  [print 'a  add x y]
add-dispatch-func/ahead 'fn-a [x [integer!] y [number!]]  [print 'b  add x y]
add-dispatch-func 'fn-a [x [number!] y [float!]]   [print 'c  add x y]
add-dispatch-func/ahead 'fn-a [x [float!] y [integer!]] [print 'd  add x y]

dispatch 'fn-a [1 2]
dispatch 'fn-a [1 2.0]
dispatch 'fn-a [1.0 2.0]
dispatch 'fn-a [1.0 2]