Field propagation between objects with transformations

Propagate.red

Red [
  title: "Propagate"
  Description: "Propagates fields values accross objects with transformations"
  Author: "Giuseppe Chillemi"
  Copyright: "MIT license"
  Version: 2.00
  Needs: {
    `Mirror` function
    https://gist.github.com/GiuseppeChillemi/99e77fa72f8a417b82d3e7502068c1a8
  }
  Usage: {

   >> propagate [ctx/a ctx2/z]

   So each time you write in a, then it is mirrored in z

   Also you can use words:

   >> propagate [a z]
   
   >> propagate reduce [in ctx 'a in ctx2 'z]
   
   or mix things:
   
   >> propagate [ctx/a z]

    This is an example of a possible mapping:

   >> propagate [
     a ctx/z
     b ctx/y
     ctx/y ctx2/sss  <- Note, it propagates the previous step 
   ]
    
    You may also provide a transformation code, as you have START and NXT as available words in the code block

    >> propagate [
      ctx/a ctx2/z  [nxt/z: to-string start/a] 
      ctx/b ctx2/y
    ]

    And also provide multiple destinations:

    >> propagate [
      a [ctx2/z ctx2/y ctx2/w ctx2/x] 
      b ctx2/s
    ]
    
    With tranformation code:

    >> propagate [
      ctx/a [ctx2/z [nxt/h: to-string start/a] ]  ctx2/y ctx2/w ctx2/x] 
      ctx/b ctx2/s
    ]
    
    To set the destination without triggerting reactions use lit-word [src 'dst]
    
    To avoid triggering reactions that point to the source word, use get-word: [:src dst]
    
  }
]

propagate: func [
	"Mirror sources to destinations. Allows transformations"
	data [block!] "Data as [source dest <opt> [code]] or [source [dest <opt> code]]"
	/local
	entry
	dest-entry
	source*
	dest*
	code
	code-block
	process-arg
	process-map-entry
	reset-vals
	blacklist
] [
	;TBD: test with none word
	;TBD: /LATER
	
	;DIALECT: [WORD!|PATH! WORD!|PATH!|LIT-WORD!|LITH-PATH! opt CODE]
	;DIALECT: [WORD!|PATH! [WORD!|PATH!|LIT-WORD!|LITH-PATH! opt CODE.... <repeat>]]
	
	
	process-arg: function [
		"Returns [TYPE WORD(:) CTX]"
		source*
		/local
		src-word
		src-type
		ctx
		path-word-of-ctx
	] [
			;TBD: manage parens in paths!!!!
						
			;--- Getting the type of the first element
			src-type: type?/word source*
			
			;--- Processing the first element
			;
			
			switch src-type [
				get-path! path! lit-path! [
					if all [object? ctx: get path-word-of-ctx: first back back tail source*] [					
						if all [src-word: first back tail source* word? src-word] [
							case [
								src-type = quote get-path! [src-word: to get-word! src-word]
								src-type = quote lit-path! [src-word: to lit-word! src-word]
							]
						]
					]   
				]
				
				word! lit-word! get-word! [
					ctx: get source* 
					src-word: source*

					case [
						src-type = quote get-word! [src-word: to get-word! src-word]
						src-type = quote lit-word! [src-word: to lit-word! src-word]
					]

				]

			]
			
			if not find words-of ctx src-word [do make error! rejoin ["Word: " src-word " not found"]]
			
			;TBD: make it return error
			reduce [src-type path-word-of-ctx src-word ctx]
	]

	;rule for source
	
	blacklist: copy []
	
	entry: [
			path!
		| 
			word!
		|
			get-path!
		|
			get-word!
	]

	dest-entry: [
			path!
		| 
			word!
		!
			lit-word!
		|
			lit-path!
	]
	
	process-map-entry: [
		(
			mirror/blacklist reduce [source*/4 dest*/4] reduce either code [[source*/3 dest*/3 code-block]] [[source*/3 dest*/3]] blacklist
		)		
	]
	
	reset-vals: [(source*: dest*: code: code-block: none)]

	if not parse data [ 
		any [
			set source* entry (source*: process-arg source*) 
			[
					set dest* dest-entry (dest*: process-arg dest* code: false) opt [set code-block block! (code-block code: true)] process-map-entry reset-vals
				| 
					ahead block! into [
						some [
							set dest* dest-entry (dest*: process-arg dest* code: false) [
								set code-block block! (code: true)  process-map-entry (code: code-block: dest*: none) 
							|
								process-map-entry (code: code-block: dest*: none) 
							]
						]
					]
			]
		]
		end
	] [
		do make error! "Invalid parse data"
	] 
]
;----- Tests and results: 

;--- Test
comment [
  ctx: make reactor! [a: 22 b: 33]
  ctx2: make reactor! [aa: 44 bb: 66]
  ctx3: make reactor! [aaa: 444 bbb: 666]
  ctx4: make reactor! [aaaa: 4444 bbbb: 6666 cccc: 9999]
  ctx5: make object! [aaaaa: 44444 bbbbb: 66666 ccccc: 99999 ddddd: 11111]

  data: [
    'ctx/a 'ctx2/bb [nxt/bb: rejoin [start/a start/a]]
    'ctx2/bb 'ctx3/bbb [nxt/bbb: rejoin [start/bb start/bb]]
    'ctx3/bbb [ctx4/bbbb ctx4/cccc]
    'ctx4/bbbb [ctx5/bbbbb [nxt/bbbbb: rejoin ["" start/bbbb "-Hello"]] ctx5/ccccc]
  ]

  propagate reduce data
  ctx/a: "55"
  probe ctx2
  probe ctx3
  probe ctx4
  probe ctx5
  halt
]

;--- Results
 comment [
	make object! [
	    aa: 44
	    bb: "5555"
	]
	make object! [
	    aaa: 444
	    bbb: "55555555"
	]
	make object! [
	    aaaa: 4444
	    bbbb: "55555555"
	    cccc: "55555555"
	]
	make object! [
	    aaaaa: 44444
	    bbbbb: "55555555-Hello"
	    ccccc: "55555555"
	    ddddd: 11111
	]
]