Func-ctx Function creator

func-ctx.red

Red [
	Title: "Func-ctx Function creator"
	Description: "100% compatible Function creator for functions that could accept a context to set its one to"
	Usage: {
		func-ctx body specs
		
		To pass a context, simply
		
		myfunc/ctx arg1 arg2... context [arg1: value arg2: value....]
		
		The context passed can have local words of the called function too
		
		;-------vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv--------vvvvvvvvvvvvv
		YOUR CODE MUST USE PATH BASED NOTATION TO ACCESS VALUES AS: ----> CTX-CODE/NAME
		;-----------------------------------------------------------------^^^^^^^^^^^^^ 
	}
	TBD: {
		More checks for duplicate words or non existing one
		Pass a default value context
		Pass a proto to calculate default values
		Values checker
		Change the name of CTX-CODE to a shorter one
		Try to discover if you can have a version with arity 0 as alternate interface
	}
]

;--- Helper function

set-words: func [
	"Set the words of the target object to value of the corresponding words in block"
	target [block! object!] "The target object"
	words [block! object!] "The words to set in the object, values will be taken"
	/any "Do not generate error if word is not found in target object"
	/clear "not mention words to none (BEWARE!)"
	/init "Init the non mentioned words to a value (BEWARE!)"
	init-value [any-type!]
	;/remap ;TBD
	;map
	/local
	wtarget
	pos
] [
	
	init-value: system/words/any [all [init :init-value] none]

	words: system/words/any [all [object? words words-of words] words]
	either not system/words/any [clear init] [

		forall words [
			
			case [
				object? target [either in target words/1 [
						set/any in target words/1 get/any words/1
					] [
						if not any [
							do make error! rejoin ["Word not found: " words/1]
						]
					]
				]
				block? target [either pos: find target words/1 [
						set/any pos/1 get/any words/1
					] [
						if not any [
							do make error! rejoin ["Word not found: " words/1]
						]
					]
				]
			]			
		]

	] [
		wtarget: any [all [object? target words-of target] target]

		forall wtarget [
			either pos: find words wtarget/1 [
				set/any wtarget/1 get/any pos/1
			] [
				set wtarget/1 :init-value
			]
		]
		if not any [forall words [if not in target words/1 [do make error! rejoin ["Word not found: " words/1]]]]
	]
	()
]



make object! [

	;------ Parse Parts	
	;
  target-container: none
	ps: none
	func-description: none
	refinement: none
	ref-description: none
	arg-word: none
	arg-string: none
	arg-datatypes: copy []
	func-description: none
	arg-proto: copy/deep [word: none types: copy [] description: none]
	all-args: copy []
	returns: none

	;----- Function builder words
	;
	specs-part: copy []	
	local-parts: copy []
	proto-block: copy []
	new-specs: copy []
	new-func-body: copy []

	;------ Rules definition
	;
	func-description-rule: [set func-description string! (append target-container func-description)]
	args-rule: [set arg-word [word! | lit-word! | get-word!] (append target-container arg-word append proto-block reduce [to-set-word arg-word none])]
	arg-types-rule: [
		ahead block! ps: set arg-datatypes block! (append/only target-container arg-datatypes) :ps into [
			
				some [set the-datatype word! if (any [datatype? get the-datatype typeset? get the-datatype])  
			
			]	
		] ;(append specs reduce [arg-word all-args)
	]
	arg-string-rule: [set arg-string string! (append target-container arg-string)]
	arg-parts-rule: [
		args-rule 
		opt arg-types-rule 
		opt arg-string-rule]
	refinement-rule: [
		set refinement refinement! (append target-container refinement append proto-block reduce [to-set-word refinement false]) opt [set ref-description string! (append target-container ref-description)]
		any arg-string-rule
	]
	return-rule: [if (any [datatype? get element typeset? get element])]
	

	;TBD: control for duplicates
	;----- Creation function
	
	set 'func-ctx func [
		specs [block!]
		body [block!]
		/sync "Arguments to sync at startup"
		args-to-sync [block!]
		/local
		fname
	] [
		
		;------ Parse Parts	init
		;
		do [
		  target-container: none
			ps: none
			func-description: none
			refinement: none
			ref-description: none
			arg-word: none
			arg-string: none
			arg-datatypes: copy []
			func-description: none
			arg-proto: copy/deep [word: none types: copy [] description: none]
			all-args: copy []
			returns: none
		]

		;----- Function builder words
		do [
			specs-part: copy []	
			local-parts: copy []
			proto-block: copy []
			new-specs: copy []
			new-func-body: copy []
		]
		
		

		parse specs [
				(target-container: specs-part)
				opt func-description-rule
				any [arg-parts-rule | /local break | refinement-rule]
				(target-container: local-parts) 
				opt [any arg-parts-rule]
				opt quote return: set returns word! if (any [datatype? get returns typeset? get returns])
				end
		]


		append new-specs specs-part
		append new-specs ctx-management-specs
		append new-specs local-parts
		if returns [append new-specs reduce [quote return: returns]]

		
		append new-func-body compose/deep [
			
			;args-to-init: (args-to-init)
			__proto: [(proto-block)]
			
			code-ctx: (make object! (proto-block))
			
			either ctx [
				;--- Using the passed context with all inits done
				;
				code-ctx: ctx* 
			] [
				;--- Creating a new context
				;
				code-ctx: either init [make __proto] [copy code-ctx]
				
				set-words/any code-ctx words-of context? 'local
				
				;<Init code here>
				
			]

			;--- Syncing arguments
			;
			if __args-to-sync [set-words code-ctx __args-to-sync] ;<--- I have a set-words function!
			
			;--- Core of the function without init, From now on you access all words using path
			;
			;code-ctx/a: ....
			;....
			
		]
		append new-func-body body
		func new-specs new-func-body
	]
	
	ctx-management-specs: [
		/ctx "Use a ctx to set the function context to"
		ctx*
		/init
		/local
		code-ctx
		__proto
		__args-to-sync
	]

]

;--- Example:
comment [

f: func-ctx [
	"My test function"
	a [integer!] "Value A"
	b [integer!] "Value B"
	/local
	x
	y	
] [
	Probe reduce [
		code-ctx/a
		code-ctx/b
		code-ctx/x
		code-ctx/y
	]
]

;--- Test passing arguments as normal
f 1 2
;--- Test passing context to set the internal one to
f/ctx 0 0 context [a: 1 b: 2 x: 3 y: 4]

;--- Result:

;[1 2 none none]
;[1 2 3 4]

]