Archive version of: parse-aid.r ... version: 2 ... luce80 17-Sep-2011

Amendment note: modified resizing, added balancing || Publicly available? Yes

REBOL [
	title: "Parse Aid"
	file: %parse-aid.r
	author: "Marco Antoniazzi"
	Copyright: "(C) 2011 Marco Antoniazzi. All Rights reserved"
	email: [luce80 AT libero DOT it]
	date: 17-09-2011
	version: 0.5.3
	Purpose: "Help make and test parse rules"
	History: [
		0.5.1 [03-09-2011 "First version"]
		0.5.2 [04-09-2011 "modified resizing"]
		0.5.3 [17-09-2011 "Added balancing, changed save format (using strings to preserve comments)"]
	]
	comment: "28-Aug-2011 GUI automatically generated by VID_build. Author: Marco Antoniazzi"
	library: [
		level: 'intermediate
		platform: 'all
		type: 'tool
		domain: 'parse
		tested-under: [View 2.7.8.3.1]
		support: none
		license: 'BSD
		see-also: none
	]
]
			
; file
	change_title: func [/modified] [
		clear find/tail main-window/text "- "
		if modified [append main-window/text "*"]
		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 temp-list job] [
		until [
			file-name: request-file/title/keep/only/filter "Load a rules file" "Load" "*.r"
			if none? file-name [exit]
			exists? file-name
		]

		job-name: file-name
		temp-list: load file-name
		if not-equal? first temp-list 'Parse_Aid-block [exit]
		job: temp-list

		set-face check-clear-res get job/clear-res
		set-face check-spaces get job/spaces
		set-face field-main-rule job/main-rule
		set-face area-charsets job/charsets
		set-face area-rules job/rules
		set-face area-test job/test

		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/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: reduce [
			'Parse_Aid-block 1
			'clear-res get-face check-clear-res
			'spaces get-face check-spaces
			'main-rule get-face field-main-rule
			'charsets get-face area-charsets
			'rules get-face area-rules
			'test get-face area-test
		]
		save job-name job

		wait 1.3
		unview
		change_title
		saved?: yes
	]
; rules
	charsets-block: copy [
		digit: charset [#"0" - #"9"]
		upper: charset [#"A" - #"Z"]
		lower: charset [#"a" - #"z"]
		alpha: union upper lower
		alpha_: union alpha charset "_"
		alpha_digit: union alpha_ digit
		hexdigit: union digit charset "abcdefABCDEF"
		bindigit: charset "01"
		space: charset " ^-^/"
	]
	rules-block: copy [
		digits: [some digit]
		sp*: [any space]
		sp+: [some space]
		
		area-code: ["(" 3 digit ")"]
		local-code: [3 digit "-" 4 digit]
		phone-num: [opt area-code copy var local-code (print ["number:" var])]
	]

	err?: func [blk /local arg1 arg2 arg3 message err][;11-Feb-2007 Guest2
		if not error? err: try blk [return :err]
		err: disarm err
		set [arg1 arg2 arg3] reduce [err/arg1 err/arg2 err/arg3]
		message: get err/id
		if block? message [bind message 'arg1]
		print ["**ERROR: " form reduce message]
	]
	prin: func [value] [
		either 100000 > length? get-face area-results [ ; avoid fill mem
			set-face area-results append get-face area-results form reduce value
		][
			alert "ERROR. Quit."
			quit
		]
	]
	print: func [value] [prin append form reduce value #"^/"]
	parse_test: func [/local result] [
		if get-face check-clear-res [reset-face area-results]
		result: err? [
			do get-face area-charsets
			do get-face area-rules
			do pick [parse/all parse] get-face check-spaces copy get-face area-test get load get-face field-main-rule
		]
		text-parsed/color: white
		show text-parsed
		wait .1 ; to see the activity
		either logic? result [
			text-parsed/color: 80 + either result [green] [red]
			text-parsed/text: uppercase form result
		] [
			text-parsed/text: "ERROR"
		]
		show text-parsed
	]
; gui
	do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
		64#{
		eJztWWuPG7cV/Wz+igsVhXcXlrS7MdJWG3fhuoVTwE6CIgkKDGYB7gyloT2aUYbU
		Sorh/vace8l5ybIdF/1YxLaGr/vifZzL/Osff/v+FSVqaUuzoD/qxuipy5q6LKfO
		H0oza5S3ntcmz7FGO+sLChtM40j2TJTe+qJusOfvNremoRcaP1s606XVjjBpXpxP
		lFlrWy4oacyb2laUTHIsZBPy9TQrdENfP6WJty7DqQn9YTKb0GTZTNJU5dpDgOu/
		TN9sy8P0+vLyqXoAd1tXC7qaXc4u1WbbbGqHTe/Uj4V1hD+aKrMjVihIGUTHLmfv
		MQIBb8GKdJXP64Ygv/21rjxmOvVm6p+edFnWO3KmNJkHR6qX5M3eU731DvKTL0DM
		mp1mqsIOFKnQDxgRhvm0rsoDrevczNR79aLeHBq7KjxkffndT/TKOEcvTWUacP5h
		e1/ajF7ZzFTO0Nmrlz+8OqcpdYfo7MU5jY3M5nivoLSvmwOsq8QibK3LP4mt6N3S
		Ng5HIUx5TpvAo4FC2pnZe5XiPxUunu20EHPZXw1IDdxhEXQTIyZK3dDFxQWJrZfb
		KlgG32yMrN5W3jQb3Xg2VvQmDDW8bD91JazWyHghZ0Hu3boWc4U10llWN7mtVsHS
		S2vKPNLBJET2S3oXlnRm3iuHYTg6b+8urswbkzd6Re906WqKAxbyaDt2ljV7g19v
		WA7PytyQfqb31j3B4JmtcEXkYJcnWH7GH60rqBQq2CVVdWVuyS/nrBslZm99qqxb
		8JTsn5LJV2bK37xPgdmC1giFq/0VM5y2h+dr3aww30/AO8OEg+MwganoDyI39K1p
		4N0wfFEjBkQ9FnsGD6no3lAOuej+gItZgxabNUjf0MZmb8XM8QiBRWsSdYP7Mbhu
		VjsoMN/TX7vvAyVXaXKdKmzDHB/HRcwRq5hY6z1dBtU6FQLh+ULTXNav2NgYsuni
		zSQgED/DWeuG+53HKFWu4IBcBrdd0EProEX74crlQm5DRefb2dwXyBVfP3r06IZy
		s9Tb0neakiy3Pv0dssYO7gdnrsltTGaXB9ppuHTeZ4YnR4cl5jnYiYN9poQAQmaz
		MVjQFYwVaGaIZEpS9pgoNyXIU/NOCd9sOY2sXKqK4YbixIZWhqAfJTCkhZwr09zK
		jvl1ODu2QlhJkR7hQIFQn6aSZalXUw4eSZ/9QtiIpAd27MXHOwcrYStu54bt+TzL
		kOLqxolsDR9YEEKtDHG4vRcS7KJsQ2SIQXwqLYfZn94aCgNYzhkvjC/aBCIkHnS5
		NSlKmXDgf+e6UeFXTs67c9QfCBuWxpRznb/ZOh8TlJM90GJ1ilmaRPpzDsNUZUim
		zaltn5BmcCbw+pwkjTmp+CeZDM78biacXQZcgnV5NnKS+A9ZSIXPbhYJ6uyaLoLH
		8x0HO4lbdF+yM6XL/WV6zsEvC100qOFwXi+XUGC+D+z6XzAKTAeuDelbasWYWjGm
		dohUut+PUGvveKDvB+KOpA3GA73wc0KekThx+z7q1DP82P3w7YZyHRKLrazneOB8
		B4SyVBtdcXSFJKOYvaTeXaM3t5R0OYRzY8qpsKoD8Jn1+QxnOFURnyFTMaxBZvSF
		xVxWl6gaS/wdAxtmJLd9jyr69jbsc3RNz6g01coX7RTyXhQ9brn68+Us/k3BRiTn
		xCLZVz/UNgdr7elnICwUMoK+JdAgnLzLPqx4OBMzzgsI502bXsImBi+t1dhIxJWD
		s8o0XDzyfHDgxwJzEsQB88k7Y0rl4IoAmBVpdyhYQiciIk5UsLmpQtTJmneK04QU
		JkkYKlRJHvKXAqwx09K6uKUbqoCSeE7wE0dPV5Q7C9zyhmECTuR+Ez7GY/gVgG0g
		w18q2D5MhG9IP0DKutzpA8C98ZLaw32cOdNqc/6E4QZgxWMvlVGuaOyTciaylOOt
		DgvxyLSttq/rnOurMGevZxMzGJwPsVpXagtTAUJZzygwEnjOwE7nA3zYIfRdgaam
		Re6YByy15Qi3M9uZYr6xxGR+L8Bqzlzo3kKfBIzurWdjgPC2kn4AWOCtOUQOQCrH
		OL8bT9FY4V4WOMgQWZypYwISboruxwLsAyxzE8RsJnff3k3v/nP3+u7fdz/f/TiJ
		bv1aV3oVW4wQiD1OXtbZlrsx9vsWigzCU4y5G1VLnXluhtKki12oISuPY2jGWJb4
		6KJX9cPOEXVItL07CplehK/omz4PDMgJbmYIOpwUTApoSV+lgc43gJwH5816zl0W
		HBjYYRqK1anjnzsT8ieE0RxKRwYxD4hbiq0A3JAhAnNxaHuyQrYkKq93aF5VVL6q
		/dT8stVlVJsZXgw4smXkcoR9WM1wh4jHUI3YAWQinBcRYqESDcORAt1fyR0gmjQ0
		VosPphF6EfN+KY9wpY302AE0M76O1kIoNm130yk64PB5BtQdp5OqUHJawyGX9LS6
		X6jpp/REG4OcRwmSfIEAKs04n4Te9yifcAzPhlSfKvhM6OhGFpBuaH85npz2qEnB
		zcYgSr7HnWA/1fWCXwi1egotDmBJWTAWEDJwe9m1ll31Gh7BDqj4395GVldLlLax
		HT5Q9QNFezv1N3YavG43coOo0ZvB/bH3GZObvINjfF3RXr0/UEed3cHbtRFijdkA
		TvyO8iKTUmNKut96H15E4jtLPhMQdaR7WNfePhgufDvUG4hQcD9/NlwQ68ESHI1z
		cVQhcx787ZRbDSBI6/6db3Jia12Sv//viZ8x3f/URxk3MKYIwIBhhCNp3E9gak6a
		waAfLa4MGm6jHkx6aYflP8KPfp0rCmObgWVD0VuxO7YIQMuD3kcUiCX0pnsAxB/u
		54GJlk29xhXCDzYlt6RhExMJ8OoINtcMpdr3J9wOrueI56jPDYVkCEsiSJcaC51R
		ovn9brx09ObYAktRFLujPqx7i8vosfRSmGyjJMYCfGijLTc/+VYqe8QAXTM47B/T
		BB1N3FB8dAMMGcB5hFQtNJcCFT1gCPTNEdIPHYHgfaW2DjPS1HSQGbVUAIy0G11E
		oY0M6PknZCvrD/0bLpJNFtqn7p7UiGJ7IyBGNt/TnC3OMNKN+iluaLmpgi07UXBi
		0Fdpft3x8ob/4SPO4NF4fJ1teh62cq4doXNu9znlOieN/WD34t+9cMK+/bND9wI3
		NqB24c6HN0fxTQCN/jW4DJmgmz76vwjMpX+OKD7NpSW8H/O7UqGZN+uNP9wO9Uz6
		79YN+pef7iEn+I2kpzZ+fwNExfRY+RkAAA==
		}
	rezize-faces: func [siz [pair!] /move] [
		area-charsets/ar/line-list: none ; to reactivate auto-wrapping
		resize-face/no-show area-charsets area-charsets/size + (siz * 1x0)

		area-rules/ar/line-list: none ; to reactivate auto-wrapping
		resize-face/no-show area-rules area-rules/size + (siz * 1x2)

		text-test/offset/x: text-test/offset/x + siz/x
		area-test/offset/x: area-test/offset/x + siz/x

		text-results/offset: text-results/offset + siz
		area-results/offset: area-results/offset + siz
		if move [siz: - siz]
		resize-face/no-show area-test area-test/size + siz
		resize-face/no-show area-results area-results/size + siz
	]
	feel-move: [
		engage-super: :engage
		engage: func [face action event /local prev-offset] [
			engage-super face action event
			if (action = 'down) [;or (action = 'up)[
				face/user-data: event/offset
			]
			if find [over away] action [
				prev-offset: face/offset
				face/offset/x: face/offset/x + event/offset/x - face/user-data/x
				face/offset/x: first confine face/offset face/size area-charsets/offset + 100x0 area-test/offset + area-test/size - 100x0

				if prev-offset <> face/offset [
					rezize-faces/move (face/offset - prev-offset * 1x0)
					show main-window
				]
			]
			;show face
		]
	]
	;append system/view/VID/vid-styles area-style ; add to master style-sheet
	main-window: center-face layout [
		styles area-style
		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]
		;check-line "save also test" on
		pad 350
		btn "Clear (T)est" #"^T" [reset-face area-test]
		btn "Clear (R)esults" #"^R" [reset-face area-results]
		check-clear-res: check-line "before every parse"
		return
		btn "(P)arse" #"^P" yellow [parse_test]
		check-spaces: check-line "also spaces" on
		;check-line "on rules update" on
		text "with this rule:" bold
		field-main-rule: field "phone-num" 300x22
		text bold "Result:"
		text-parsed: text bold as-is "  NONE  " black white center
		return
		Below
		guide
		style area-scroll area-scroll 400x200 hscroll vscroll font-name font-fixed para [origin: 2x0 Tabs: 10]
		text bold "Charsets"
		area-charsets: area-scroll wrap
		text-rules: text bold "Rules"
		area-rules: area-scroll wrap
		return
		button-balance: button "|" 6x450 gray feel feel-move edge [size: 1x1]
		return
		text-test: text bold "Test"
		area-test: area-scroll "(707)467-8000"
		text-results: text bold "Results"
		area-results: area-scroll silver read-only
		key (escape) (sp * 0x-1) [ask_close]
	]
	main-window/user-data: reduce ['size main-window/size]
	insert-event-func func [face event /local siz] [
		switch event/type [
			close [
				ask_close
				return none
			]
			resize [
				face: main-window
				siz: face/size - face/user-data/size / 2     ; compute size difference / 2
				face/user-data/size: face/size          ; store new size

				rezize-faces siz
				button-balance/offset: button-balance/offset + (siz * 1x0)
				button-balance/size: button-balance/size + (siz * 0x2)
				show main-window
			]
		]
		event
	]
	ask_close: does [
		either not saved? [
			switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
				yes [quit]
				no [if save_file [quit]]
			]
		][
			if confirm "Exit now?" [quit]
			;quit
		]
	]
; main
	
	set-face area-charsets trim mold/only charsets-block
	set-face area-rules trim mold/only rules-block

	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]