Archive version of: mini-edit-do.r ... version: 10 ... luce80 13-Jan-2013

Amendment note: Added pseudo-console || Publicly available? Yes

REBOL [
	title: "Mini-edit-do"
	file: %mini-edit-do.r
	author: "Marco Antoniazzi"
	Copyright: "(C) 2012,2013 Marco Antoniazzi. All Rights reserved"
	email: [luce80 AT libero DOT it]
	date: 03-01-2012
	version: 0.6.1
	Purpose: "Helps test short programs (substitutes console)"
	History: [
		0.0.1 [30-04-2012 "First version"]
		0.5.1 [01-05-2012 "Fixed using view and quit"]
		0.5.2 [05-05-2012 "Added undo and redo"]
		0.5.3 [10-05-2012 "Fixed last probe"]
		0.5.4 [12-05-2012 "Added halt and other minor fixes"]
		0.5.5 [20-05-2012 "Fixed error inside prin and script header"]
		0.5.6 [03-06-2012 "Fixed bug when deleting all"]
		0.5.7 [08-06-2012 "Fixed undo after clear all"]
		0.5.8 [29-07-2012 "Fixed arg1 etc. in err?"]
		0.5.9 [09-08-2012 "Fixed ^X and save after clear all, arg1, do-face"]
		0.6.1 [03-01-2013 "Added pseudo-console"]
	]
	comment: {30-Apr-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi.
		Derived directly from ParseAid.r
	}
	library: [
		level: 'intermediate
		platform: 'all
		type: 'tool
		domain: [debug testing]
		tested-under: [View 2.7.8.3.1]
		support: none
		license: 'BSD
		see-also: %parse-aid.r
	]
	todo: {
		- options: 
			- set max area-results length
			- set max dumped obj length
			- choose between head or tail of dumped obj
		- patch ALL functions to use err? (to output errors to my prog)
	}
]

	err?: func [blk /local arg1 arg2 arg3 message err][;derived from 11-Feb-2007 Guest2
		if not error? set/any 'err try blk [return get/any 'err]
		err: disarm err
		arg1: any [attempt [get in err 'arg1] 'unset]
		arg2: get in err 'arg2
		arg3: get in err 'arg3
		message: get err/id
		if block? message [bind message 'arg1]
		prin* ["**ERROR:" form reduce message newline]
		prin* ["**Near:" either block? err/near [mold/only err/near][err/near] newline]
		throw
	]
; patches
	doing: false
	old-length: 0
	old-prin: :prin old-print: :print ; use these to output to console
	old-probe: func [value] [old-print mold :value :value]
	old-quit: :quit
	quit: does [
		; closing all windows (except ours) is similar to quitting ...
		foreach face next System/view/screen-face/pane [unview/only face]
	]
	halt: does [] ; avoid opening console
	prin*: func [value][
		set-face/no-show output-face append get-face output-face form reduce value
		system/view/vid/vid-feel/move-drag output-face/vscroll/pane/3 1 ; autoscroll down
	]
	prin: func [value] [
		either all [(100000 + old-length) > length? get-face output-face doing] [ ; avoid fill mem
			set-face/no-show output-face append get-face output-face form err? [reduce value]
			system/view/vid/vid-feel/move-drag output-face/vscroll/pane/3 1 ; autoscroll down
			wait 0.0001 ; avoid blocking the gui
		][
			if confirm/with "ERROR. Probable infinite loop. Clear Results?" ["Yes" "Cancel"] [reset-face output-face]
			throw
		]
		exit ; force unsetting result
	]
	print: func [value] [prin value prin newline]
	probbed: none
	probe: func [value] [probbed: get 'value print mold :value :value]
	*isolator: context [
		func: make function! [
		    "Defines a user function with given spec and body." 
		    [catch] 
		    spec [block!] {Help string (opt) followed by arg words (and opt type and string)} 
		    body [block!] "The body block of the function"
		][
		    throw-on-error [make function! spec compose/deep [err? [(body)]]]
		]
		view: func ; taken from "REBOL Word Browser (Dictionary)" Author: "Carl Sassenrath"
			first get in system/words 'view
			head insert copy/deep second get in system/words 'view [new: true]
	]
	do-face: func [face value] [ ; (needs to work for functions and blocks)
		err?[do get in face 'action face either value [value][face/data]]
	]
	do-face-alt: func [face value] [
		err?[do get in face 'alt-action face either value [value][face/data]]
	]
	ctx-text/next-word: func [str /local s ns] [
		s: charset " ^-^/^M" ns: complement s
		any [all [s: find str s find s ns] tail str]
	]
	ctx-text/back-word: func [str /local s ns] [
		s: charset " ^-^/^M" ns: complement s
		any [all [ns: find/tail/reverse str ns ns: find/reverse ns s next ns] head str]
	]
	resize-face: func [
		"Resize a face."
		face
		size [number! pair!]
		/x "Resize only width"
		/y "Resize only heigth"
		/no-show "Do not show change yet"
		/local access
		][
		either all [
			access: get in face 'access
			in access 'resize-face*
		][
			access/resize-face* face size x y
		][
			face/size: size * (add 1x0 to-integer not x 0x1 to-integer not y)
		]
		if not no-show [show face]
		face
	]
;
context [ ; protect our functions from being redefined
; file
	change_title: func [/modified] [
		clear find/tail main-window/text "- "
		either modified [append main-window/text "*" saved?: no][saved?: yes]
		append main-window/text to-string last split-path any [job-name %Untitled]
		main-window/changes: [text] show main-window
	]
	open_file: func [/local file-name job] [
		until [
			file-name: request-file/title/keep/only/filter "Load a Rebol file" "Load" "*.r"
			if none? file-name [exit]
			exists? file-name
		]

		job-name: file-name
		job: read file-name
		set-face area-test job
		code: copy job

		named: yes
		change_title
		saved?: yes
	]
	save_file: func [/as /local file-name filt ext response job] [
		;if empty? job [return false]
		if not named [as: true]

		if as [
			filt: "*.r"
			ext: %.r
			file-name: request-file/title/keep/only/save/filter "Save as Rebol file" "Save" filt
			if none? file-name [return false]
			if not-equal? suffix? file-name ext [append file-name ext]
			response: true
			if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]]
			if response <> true [return false]
			job-name: file-name
			named: yes
		]
		flash/with join "Saving to: " job-name main-window

		job: get-face area-test
		write job-name job
		code: copy job

		wait 1.3
		unview
		change_title
		saved?: yes
	]
; do
	test: func [text /console /local script result temp] [
		if get-face check-clear-res [reset-face area-results old-length: 0]
		err? [
			probbed: none
			text: rejoin ["[" copy text "]"]
			script: attempt [load/header text]
			if none? script [script: load text insert script make system/script/header [] ]
			system/script/header: script/1 ; replace our header with the script's one
			doing: true
			set/any 'result do bind script *isolator
			text: none recycle
			old-length: old-length + length? get-face area-results
			if not unset? get/any 'result [
				temp: copy/part mold :result 10000
				if (length? temp) = 10000 [append temp "..."]
				either console [
					print ["==" temp]
				][
					if not equal? mold :probbed temp [ ; avoid reprinting last result
						print temp
					]
				]
			]
			doing: false
		]
		get/any 'result
	]
; gui
	;do %area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
	do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
		64#{
		eJztWUuP5LYRvutXMJ3D2gvIml4bgSHsZg65+OJbYCwg9BgciWopq5Y6Enu6J0H8
		2/NVFUlR3T0vZ4NcYsMekawq1otVH9mJHo1OJ/vYmVzRn/YfRhWJzJbj0HW5ooE6
		trbBwqGvhlxVg5lUoceMhhuVjGYxS0PM6qr61Q6/Ek3atZPNVX3oS1CUdsN05wSK
		V5K6PaVT11ZmTPd61J4tWe2GB6O0kjUQl8NYtf1WWXOyqm5NVynRGZPfrVRia7WS
		NV0ajCeMhTkTOkhxS6TzqLdqpbtpUG5gG6PO6Im0G0rdKbvbky5WtVMCc5K2Vv3Q
		m1tl64zUVoU5tWROO+U0N5FnU2WqrUnpmwih4m6fq13bq/VpDUkgcOzZTo9bzM8T
		w9jKBHmSJKRsG0mBj6Y60ycIgJFZpS1mdvqkbkR2kCFmZLlWmTKIKBwADWj88c8g
		LmQAc9akeO0dUUCo+xR57SQyaI81FGKmZGqGIxRJKPZjrh58AjX+Y+rqnL0EWp5K
		j21lm1yt/6SSI6IJV+n93vSV0v2jKnhKlcMe3xtyshOpit4csyDfjgfkxbidsHET
		UzTXKHwoZW9VwMy2t2ZrxlsmyT4I81JDWdmonnzuJOFcVOnQd9Cu7vQ2pVwCwVHN
		C45yOFhsSLE/J41WmJadV5ZmmiiCX4ySAWyfjGW29/5AsIwH3R0MuYZGOadzpkeV
		yAfzZoFTzSyOojamwzn822Gy7sxNQpSUndFyPLL5gMazdMp5llTeXlNuI3+gT0ap
		unHsVwnP9efjZJXZ7e3jrUxzujuJ55UDyhygdfFuRD5ywswsnem3tomEbDZL/0Ra
		OeOf9U3Cob8ajhcCEXG9YSM66peBp2m/HRcXKQrIb/4O0ygY33xQ7+VAaToZvMQZ
		F74ykXZzutl8y77nlXDakniYDXUNM7KTbDj/xU6ya3Rwks0srlmKa5biHp2Y8Pcp
		cT6lYpsvNF4oLD6ERPlzTaWFRo7+5OyK9nwqUlhL5OhK9Wr71tKRpXo3mQ4leq97
		aOtKGSvABfk46v2tKkKhouIoyxyqe/SaL7dg6wbs9EF9CsksU9RHZUdHsv7x5jv3
		H6kdSg0rQcMp6EgaKarTVGZScfXelJI077jpw4IHZN30OFmzyx5a1KskaufBmlAK
		orlnur+z6w8b1zfXN/hHfQy2zce6GA03/XtdflFWt928Rl7qJzPajAttg5IbMbIa
		tJWrWItiJSCm0ZPHIqSEqzTR3q5/gwQNhEpxVAcvtg4byK7wW1bCh9SqAZ3KBvhk
		dIvYzhtGXRmTViAMFtF86P8/kFPRmniXK+vfc7Jdy0YqORxQ3j19aKf2vkP8vT6+
		S3d1EoDbdU/MFl16Yl57Lgiv88QzRrITXvLU1/HEJaVPWJ50rhFGYCW2VBpSUtoT
		QzFU0tYKKMPe5bDbDxNa0tS0tVXf1ECW5ltM9xZHPYy/GLht2FEp3yycxSnvFP2P
		dwB0bMiGjVSpne41YKicA7GSqByyBT5QZbcHrCOXo1Q447kilY0GTiLqP67u/rIi
		X2DA2EyjfgVNm7ajPW9V4nAmc5No8H1eoZI5NtR+WDBvdS4hHXW/BVq+KChxz2/7
		ypxuncZ09iVdglglTeY2solBu9ONkAapBm04RbPK1PrQWbazSKDxTysGihjnat8i
		MhyeOZfWOEAv63fGRNLXG0Ij2OG38x3eKvwJuT+vnuNuL7nBk62In9l/eSs7Midn
		AIyvdn8/6LHKs2zuW93eSf78rOSA4xYQTtAbh+5NSolHEuH8X2VcALU1mFUhWSWR
		lzixuzcu6V5jH4v2trF4idint8p4RdCS8C+1jU5bU8XdvrTt0Ps3ANTUTGYEeDj0
		T3/4Eii4PJF7Ko3pSyW4txuHFWgyDAk9jY6Sr9YJYdbc32ADyrklivhGVQicYn1o
		gjoFqqNIoi+UVsZNMuMw1BLEMWhyHIyfvBY5IzjXfNxlbVGo1T3Heb4mpnXbQbcc
		LZJcw84LHIjYlNohde2Q6iwl6j/vfrpL7367+/nu890vd3/9F/fsUR8XdwHqpWgF
		cZ3GNZ2X3jmjHJJkmBewYzIPgze1IPTZpyxmvtF+rz5+Wl6pRBwfLS5c0aRUsmKt
		0MtZDtpFhCYRAzSc1N11rrC/xCPpCGX01lx4xDwYRNg1NWAIKvGbUOMdAKmGYy9u
		Oze5aicNGFAF+DM3i9T8/aA7R0dKvY+0Iu8N5SFc4QRTkS5ZNRwgMcUZI69ca+ss
		4KXGTq8Z0tc7U1tBDq+VJbxXRAWIAENhbzIbLLoLf+FrmFjdgElqptSR4up07qgd
		kkrOiXDYclcv6QRIyWbtZWtZYlcGMw+98NJAsiDa4xXS3J1uRB0LT1IEB/29G5Bz
		DNb6eEdbvGKH/56vvqapfGs96kdfDYTsB4DE4UGeJhey+FXxdLOcTKPnBsGB8fMD
		fy/fNOep8Kr51keKWYS/O5OupBqpSGgujV5J2SnnLKCgsvB7fYxDhE5+5usLYy9M
		jVwVwkBY4+rzz2HvipMPjfNMFMwghENp2x1VIA7etRhBE0zKdd+nR4g0ecMHmL7/
		H9dXuO8rR1yQm6sc4rIne7FcxkRP4mNgeQ435nUqoNHVL2JMzrqGtM4trAs4wuG5
		62r7TrxcPH8ZhVExDHEokvsllEZLpt9UlktnvwX5XyFYJVD7jaGl7wzqHUFOzPlE
		dtmKGO91OwYI7LtbeDKM3xmh7c3cAJsnSZKAKB2I8nBSyqzH+xFANWcIVZCse/Y7
		UKPml4jw+xSaAmMWRsoh7cPbhqfzrgaJaquTysiVDPGmxQMfPWjSKx+8FHYASzFD
		ehLt0fyV3xmcCxiGL0IVKlD8vDiDaf5ZUCjpRyp3XZlfmMOPOUvz9SRRiz2v3ONv
		9qg+ODnz03LzvBzPelpKXDs57ukrUraYv0OY5tf88DQvgaWxPwz/Bja6BRBaHQAA
		}
		resize-faces: func [siz [pair!] /move] [
		foreach [face dir] reduce [text-results 0x1 area-results 0x1 field-console 0x1 text-command 0x1] [face/offset: face/offset + (siz * dir)]
		foreach [face dir] reduce [area-test 1x1 area-results 1x0 field-console 1x0 area-console-results 1x1] [resize-face/no-show face face/size + (siz * dir)]
		either not move [
			foreach [face dir] reduce [panels 1x1 panel-edit 1x1 panel-console 1x1] [resize-face/no-show face face/size + (siz * dir)]
		][
			; "undo" vertical resizing
			foreach [face dir] reduce [area-results 0x-1] [resize-face/no-show face face/size + (siz * dir)]
		]
	]
	feel-move: [
		engage-super: :engage
		engage: func [face action event /local prev-offset] [
			engage-super face action event
			if find [over away] action [
				prev-offset: face/offset
				face/offset: 0x1 * (face/old-offset + event/offset) ; We cannot modify face/old-offset but why not use it?
				face/offset: 0x1 * second confine face/offset face/size area-test/offset + 0x100 area-results/offset + area-results/size - 0x100
				face/offset: face/offset + 4x0 ; ?? must add spacing

				if prev-offset <> face/offset [
					resize-faces/move (face/offset - prev-offset * 0x1)
					show main-window
				]
			]
		]
	]
	append system/view/VID/vid-styles area-style ; add to master style-sheet
	; panels
		panel-edit: layout/tight [
			do [sp: 4x4] origin sp space sp
			Across
			btn "(O)pen..." #"^O" [open_file]
			btn "(S)ave" #"^S" [save_file]
			pad (sp * -1x0)
			btn "as..." [save_file/as]
			btn "Undo" #"^z" [area-test/undo if strict-equal? code get-face area-test [change_title]]
			btn "(R)edo" #"^r" [area-test/redo if strict-not-equal? code get-face area-test [change_title/modified]]
			btn "(D)o script" #"^D" 70 yellow [if get-face check-clear-res [clear-face area-results] test get-face area-test]
			btn "H(a)lt" #"^A" red [if doing [doing: false make error! "Halt"]]
			btn "Clear (T)est" #"^T" [if confirm "Are you sure?" [clear-face area-test job-name: none named: no change_title/modified]]
			btn "Clear R(e)sults" #"^e" [clear-face output-face old-length: 0]
			pad 0x1
			check-clear-res: check-line "before every do" off
			return
			Below
			style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			text-test: text bold "Test"
			area-test: area-scroll {print "Hello world!"} with [append init [deflag-face self/ar 'tabbed ]]
			button-balance: button "-----" 650x6 gray feel feel-move edge [size: 1x1] font [size: 6]
			text-results: text bold "Results"
			area-results: area-scroll silver read-only
		]
		{panel-console: layout/tight [
			do [sp: 4x4] origin sp space sp
			style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			area-console: area-scroll {>> probe "Hello world!"} panel-edit/size - 1x1 - 8x8 with [append init [deflag-face self/ar 'tabbed ]]
			do [
				super-engage: get in area-console/ar/feel 'engage
				area-console/ar/feel/engage: func [face action event /local code result][
					either #"^M" = event/key  [
						set-face/no-show area-console append get-face area-console newline ; append newline
						code: find/tail/last get-face area-console {>> }
						;insert console-history code
						result: test/console rejoin ["[" copy code "]"]
					][
						super-engage face action event
					]
				]
			]
		]}
		console-history: copy []
		panel-console: layout/tight [
			do [sp: 4x4] origin sp space sp
			style area-scroll area-scroll hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
			across
			pad 251
			btn "Do script" 70 yellow [if get-face check-clear-res [clear-face area-results] test get-face area-test]
			btn "H(a)lt" #"^A" red [if doing [doing: false make error! "Halt"]]
			pad 77
			btn "Clear R(e)sults" #"^e" [clear-face output-face old-length: 0]
			pad 0x1
			check-clear-res-cons: check-line "before every do" off
			below
			text bold "Results =="
			area-console-results: area-scroll panel-edit/size - 8x108 silver read-only
			text-command: text bold "Command >>"
			field-console: field {probe "Hello world!"} panel-edit/size/x - 1 - 8 font-name font-fixed with [
				append init [deflag-face self 'tabbed deflag-face self 'on-unfocus]
			] feel [
				super-engage: :engage
				engage: func [face action event /local code][
					if action = 'key [
						switch event/key [
							up [
								console-history: back console-history
								code: pick console-history 1 
								if code [set-face face code focus face]
							]
							down [
								console-history: next console-history
								if tail? console-history [console-history: back console-history]
								code: pick console-history 1
								if code [set-face face code focus face]
							]
						]
					]
					super-engage face action event
				]
			] [ ; action function
				if get-face check-clear-res-cons [clear-face area-console-results] 
				use [code][
					code: copy get-face face
					if (pick back tail console-history 1) <> code [console-history: back insert tail console-history code]
					test/console code
				]
			]
		]
		set 'output-face area-results ; make it global
		set 'input-face area-test ; make it global
	show-pane: func [face [object!] pane [object!] input [object!] output [object!]][
		if get-face face [set 'output-face output set 'input-face input focus input panels/pane: pane show panels]
	]
	main-window: center-face layout [
		style radio-line radio-line font [style: 'bold]
		do [sp: 4x4] origin sp space sp
		Across
		radio-line "Mini editor" on [show-pane face panel-edit area-test area-results]
		radio-line "Mini console" off [show-pane face panel-console field-console area-console-results]
		;radio-line "Mini source level debugger" off
		;radio-line "Mini function builder" off
		return
		panels: box panel-edit/size + 1x1 edge [size: 1x1] with [pane: panel-edit] ; + 1x1 is because edge [size: 1x1]
		at -1000x-10000
		key keycode [f2] [focus input-face]
		key escape (sp * 0x-1) [ask_close]
		do [
			code: copy area-test/text
			old-add_to_undo-list: get in area-test/ar 'add_to_undo-list
			area-test/ar/add_to_undo-list: func [key] [change_title/modified old-add_to_undo-list key]
		]
	]
	main-window/user-data: reduce ['size main-window/size]
	insert-event-func func [face event /local siz] [
		if event/face = main-window [
			switch event/type [
				close [
					ask_close
					return none
				]
				resize [
					face: system/view/screen-face/pane/1
					siz: face/size - face/user-data/size     ; compute size difference
					face/user-data/size: face/size          ; store new size

					resize-faces siz
					button-balance/offset: button-balance/offset + (siz * 0x1)
					button-balance/size: button-balance/size + (siz * 1x0)
					show face
				]
				scroll-line [either event/offset/y < 0 [scroll-drag/back/page area-test/vscroll] [scroll-drag/page area-test/vscroll]]
			]
		]
		event
	]
	ask_close: does [
		either not saved? [
			switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
				yes [old-quit]
				no [if save_file [old-quit]]
			]
		][
			if confirm "Exit now?" [old-quit]
			;old-quit
		]
	]
; main
	
	job-name: none
	named: no
	saved?: yes
	main-title: join copy System/script/header/title " - Untitled"
	view/title/options main-window main-title reduce ['resize 'min-size main-window/size + system/view/title-size + 8x10 + system/view/resize-border]
] ; context