Script Library: 1238 scripts
  • Home
  • Script library
  • AltME Archive
  • Mailing list
  • Articles Index
  • Site search
 

Archive version of: parse-aid.r ... version: 1 ... luce80 3-Sep-2011

Amendment note: new script || 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: 03-09-2011
	version: 0.5.1
	Purpose: "Help make and test parse rules"
	History: [
		0.5.1 [03-09-2011 "First version"]
	]
	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 trim mold/only job/charsets
		set-face area-rules trim mold/only 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 load get-face area-charsets
			'rules load 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 "_"
		alphadigit: union alpha_ digit
		hexdigit: union digit charset [#"a" - #"f" #"A" - #"F"]
		bindigit: charset "01"
		space: charset [#" " #"^(09)" #"^(0D)" #"^(13)"]
	]
	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] [
		if 100000 > length? get-face area-results [ ; avoid fill mem
			set-face area-results append get-face area-results form reduce value
		]
	]
	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 ; Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
		#{
		789CED596B8FDBC615FDECF915172A0AEF2E2C717763A4AD36EEC2750BA7809D
		0445121420B8C02C3914C7A648851CADA418EE6FCFB977862F59B6E3A21F8BD8
		16E7755F731FE74EFEF58FBF7DFF8A6295DBD22CE98FBA317ADEA64D5D96F3D6
		1D4AB36894B38ED766CFB1463BEB0AF21B4CD392EC9929BD7545DD60CFDF6D66
		4D432F347EB674A64BAB5BC2A479713E5366AD6DB9A4B8316F6A5B513CCBB090
		CEC8D5F3B4D00D7DFD9466CEB6294ECDE80FB3C58C6679334B1295690701AEFF
		327FB32D0FF3EBCBCBA7EA01DC6D5D2DE96A71B9B8549B6DB3A95B6C7AA77E2C
		6C4BF8A3A9323B6285BC945E74EC6AED3D4620E02C5891AEB2A86E08F2DB5FEB
		CA61A6576FA1FEE9489765BDA3D6942675E048754ECEEC1DD55BD7427E720588
		59B3D34C55D8812215FA0123C2309BD75579A0759D99857AAF5ED49B43635785
		83AC2FBFFB895E99B6A597A6320D38FFB0BD2F6D4AAF6C6AAAD6D0D9AB973FBC
		3AA739F587E8ECC5394D8DCCE678AFA0B4AB9B03ACABC4226CADCB3F89ADE85D
		6E9B1647214C794E1BCFA38142BA358BF72AC17FCA5F3CDB6929E6B2BF1A901A
		B9C3D2EB26468C95BAA18B8B0B125BE7DBCA5B06DF6C8CB4DE56CE341BDD3836
		56F0260C35BC6C3F6F4B58AD91F152CE82DCBB752DE6F26BA4D3B46E325BADBC
		A5736BCA2CD0C124447639BDF34B3A35EF558BA13F1A75771756A2C6648D5ED1
		3B5DB63585010B79B41D3BCB9ABDC1AD372C8763656E483FD37BDB3EC1E099AD
		7045D4C22E4FB0FC8C3F3A57500954B0395575656EC9E511EB46B1D95B9728DB
		2E794AF6CFC9642B33E76FDEA7C06C496B84C2D5FE8A19CEBBC3D15A372BCC0F
		13F04E3FD1C27198C05CF407911BFAD634F06E18BEA81103A21E8BBD80875474
		6F28835C747FC0C5AC418BCDEAA56F6863D3B762E67084C0A23389BAC1FD185C
		37ABED1588F6F4D7FEFB40F155125F270ADB30C7C77111116215136BBDA74BAF
		5AAF82271C2D35456C667CB0D1C29DC4381A3EFD29DBFA9D4CE90A5A6394A8B6
		E050CCBDC32EE9A173CDA2FB68CB7C29F7A082DBED6CE60A6489AF1F3D7A7443
		99C9F5B674BD8E24CB9D377F877CB183E3C18D6B6A3726B5F981761ACE9C0D39
		E1C9D16189760E73E2305F28218060D96C0C16740533799A296298E2847D25C8
		4D313254D42BE19A2D2790559BA862BCA138B1A193C1EB47310C6921E7CA34B7
		B223BAF667A756F02B0912235CC7131A12549C977A35E7B091C4392CF88D4877
		60C7FE7BBC73B4E2B7E2766ED89ECFD314C9AD6E5A91ADE1034B4290953E02B7
		F742829D936D88DC308A4CA5E5307BD25B437E00CBB5C609E38B2E750889075D
		6E4D8222261CF8DF4837CAFFCAC9A83F47C301BF2137A68C74F666DBBA909A5A
		D9032D56A7982571A01F7100262A451A6D4E6DFB8434A3339ED7E72469CC49C5
		3FC96474E67733E1BC32E2E2ADCBB3819344BECF3FCA7FF6B3484D67D774E13D
		9EEFD8DB49DCA2FF929D095DEE2F93730E7E59E8A3418D87519DE75020DA7B76
		C32F1879A623D786F41DB5624AAD98523B042AFDEF47A875773CD2F7037127D2
		7AE3819EFF3921CF449CB07D1F741A187EEC7EF8767DA1F689C556D6713C70BE
		0336C9D546571C5D3EC928662F4977D7E8CD2DC57D0EE1DC98702AAC6A0F7916
		433EC3194E55C467C8540C6890195D613197D625EA458EBF5348C38CE4B6EF51
		3FDFDEFA7D2D5DD3332A4DB572453785BC17440F5BAEFE7CB9087F13B011C939
		B148F6D50FB5CDC05A3BFA19D80A258CA06F091C0827EFB30F2BEECF848CF302
		C239D3A517BF89614B6735361271E5E0AC32F7178F3CEF1DF8B1009C1871C07C
		B2DE985239B822006005DA3DFE95D009588813156C6E2A1F75B2E65AC569420A
		93240CE5EB230FF94B01D0987969DBB0A51F2A8F8F784E9013474F5F8E7B0BDC
		F28671028EE57E633EC663F81520AD27C35FCADBDE4FF86F483FC2C8BADCE903
		60BD7192DAFD7D9CB5A6D3E6FC09030D008AC74E2AA35CD1D427E54C6029C73B
		1D96E29149576D5FD719D75761CE5ECF266618188D515A5F6A0B53013C59C7F8
		2F1078CE904E672364D863F35D8176A6C3EC980720B5E504B133DB8562BEA1C4
		A46E2F902A622E746FA14F0C46F7D6B13140785B4927002CF0D61C0207209563
		84DF8FE768A9702F4B1C64702CCED4330189768EBEC702E6032673FBC36C6677
		DFDECDEFFE73F7FAEEDF773FDFFD380B6EFD5A577A159A0B1F880342CEEB74CB
		7D18FB7D074546E129C6DC4DAAA54E1DB74149DCC72ED49095C72134432C4B7C
		F4D1AB8661EF88DA27DAC11D85CC20C257F4CD900746E4043133F81C4F0A1A05
		A8A4AF124FE71B80CD43EBCC3AE2FE0A0E0CEC30F7C5EAD4F1CF9DF1F913C268
		0EA523839807C42D8526006EC81081B9B46878D242B6C42AAB77685B5550BEAA
		DDDCFCB2D565509B195E8C38B265E47284BD5F4D718788475F8DD80164C29F17
		1142A1120DFD91027D5FC9BD1FDA33B454CB0FA6117A01F37E290F7FA58D74D7
		1E3433BE0ED64228365D5FD32B3AE2F07906D41FA793AA507C5AC33197E4B4BA
		5FA8E9A7F44403839C4731927C81002ACD349FF8AEF7289F700C2FC6549F2AF8
		8CEFE52616903E687F399D9C0FA849C1CDA6204ABEA73DE030D577815F08B506
		0A1D0E604959301610327063D937957DF51A1FC10EA8F8DFDE465A57394ADBD4
		0E1FA8FA81A2839D861B3B0D5EB71BB941D4E8CDE8FED8FB8CC94CD6C331BEAE
		60AFC11FA8A7CEEEE0ECDA08B1C66C00277E47799149A93125DD6F9DF36F21E1
		85255B08883AD2DDAF6B671F0C17BE1DEA0D4428B8933F1B2F88F560098EC648
		1C55C89C7B7F3BE5562308D2B97FEF9B9CD83A97E4EFFF7BE2674CF73FF551C6
		0D8C293C306018D19234EE273035274D6FD08F1657060DB7410F269DDB71F90F
		F06358E78AC2D86664595FF456EC8E1D02D0F294F711054209BDE99FFEF087FB
		7960A2BCA9D7B842F8C1A6E496D46F62221E5E1DC1E69AA154F7F284DBC1F51C
		F19CF4B9BE908C614900E95263A1334A34BFDC4D978E5E1B3B60298A6277D087
		75EF70193D965E0A935D948458800F6DB4E5E627DB4A650F18A06F06C7FD6312
		A3A3091B8A8F6E80213D380F90AA83E652A082078C81BE3942FABE2310BCAFD4
		B6C58C34353D64462D150023ED461F5168233D7AFE09D9CABAC3F07A8B6493FA
		F6A9BF2735A1D8DD088891CDF614B1C51946B6937E8A1B5A6EAA60CB5E149C18
		F5559A5F779CBCDE7FF888337A2E9E5E67979EC7AD5CDB8DD03977FB5AD5F64E
		1AFAC1FEADBF7FDB847D876787FE056E6A40DDFA3B1FDF1C85370134FAD7E032
		66826EFAE8FF1F3097E139A2F834978EF07ECAEF4AF966DEAC37EE703BD6331E
		BE3B37185E7EFA871CEF37929EBAF8FD0D55CCF2A1F3190000
		}
	;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
		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

				resize-face area-charsets area-charsets/size + siz

				text-rules/offset/y: text-rules/offset/y + siz/y
				area-rules/offset/y: area-rules/offset/y + siz/y
				resize-face area-rules area-rules/size + siz

				text-test/offset/x: text-test/offset/x + siz/x
				area-test/offset/x: area-test/offset/x + siz/x
				resize-face area-test area-test/size + siz

				text-results/offset: text-results/offset + siz
				area-results/offset: area-results/offset + siz
				resize-face area-results area-results/size + siz
				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]