(define-module html-form-fill
	(use gauche.regexp)
	(export
		html-form-fill
		html-form-fill-by-hash-table))

(select-module html-form-fill)

(define
	html-form-fill-by-hash-table
	(lambda
		(body form-param)
		
		(letrec

		((inner-regexp
			(string-append
				"(?:"
				"[^\\\s]+|"
				"[^\\\s]+\\\s"
				"(?:[^\"\'\>]*?(?:\"[^\"]*?\"|\'[^\']*?\'))*?"
				"(?:[^\"\'>]*?)"
				")"))

		(
			html-split
			(lambda
				(body)
				(let
					((
						html-match
						(rxmatch
							(string->regexp
								(string-append
									"^(.*?)(\<\!\-\-.*?\-\-\>|\<" inner-regexp "\>)(.*?)$"))
							body)))
				(if
					(not html-match)
					(list body)
					(cons
						(rxmatch-substring html-match 1)
						(cons
							(rxmatch-substring html-match 2)
							(html-split (rxmatch-substring html-match 3))))))))


		(
			form-fill
			(lambda
				(html-list form-param current-type current-name)
				(let
					(
						(ctype current-type)
				 		(cname current-name))
				(if
					(null? html-list)
					""
					(string-append
						(if
							(and
								(form? (car html-list))
								(hash-table-exists?
									form-param
									(if
										(> (string-length cname) 0)
										cname
										(form-name-get (car html-list)))))
							(begin
								(let
									(
										(form-type
											(form-type-get (car html-list))))
									(cond
										((or
											(string=? form-type "text")
											(string=? form-type "password")
											(string=? form-type "hidden"))
											(value-set
												(value-clear (car html-list))
												(form-name-get (car html-list))
												form-param))
										((string=? form-type "radio")
											(checked-set
												(checked-clear (car html-list))
												(form-name-get (car html-list))
												form-param))
										((string=? form-type "checkbox")
											(checked-set
												(checked-clear (car html-list))
												(form-name-get (car html-list))
												form-param))
										((string=? form-type "option")
											(selected-set
												(selected-clear (car html-list))
												cname
												form-param))
										((string=? form-type "select")
											(set! ctype "select")
											(set! cname
												(form-name-get (car html-list)))
											(car html-list))
										((string=? form-type "/select")
											(set! ctype "")
											(set! cname "")
											(car html-list))
										((string=? form-type "textarea")
											(set! ctype "textarea")
											(set! cname
												(form-name-get (car html-list)))
											(car html-list))
										((string=? form-type "/textarea")
											(let
												((textarea-body
													(hash-table-get
														form-param
														cname)))
												(set! ctype "")
												(set! cname "")
												(string-append
													textarea-body
													(car html-list))))

										(#t (car html-list)))))
							(if
								(string=? ctype "textarea")
								""
								(string-append (car html-list) "")))
						(form-fill
							(cdr html-list)
							form-param
							ctype
							cname))))))

		(
			form?
			(lambda
				(html-str)
				(if
					(or
						(rxmatch
							(string->regexp
								(string-append
								"(?i:\<input .*?type\=(\"|\'|))"
								"(?i:radio|checkbox|text|password|hidden)"
								"(?i:(\"|\'|\s*?).*?\>)"))
							html-str)
						(rxmatch
							(string->regexp
								"(?i:\<option.*?\>)")
							html-str)
						(rxmatch
							(string->regexp
								"(?i:\<)(?i:select|\/select)(?i:.*?\>)")
							html-str)
						(rxmatch
							(string->regexp
								"(?i:\<)(?i:textarea|\/textarea)(?i:.*?\>)")
							html-str))
					#t
					#f)))

		(
			form-name-get
			(lambda
				(html-str)
				(let
					((
						form-match
						(or
							(rxmatch
								(string->regexp
									(string-append
										"(?i:\<"
										inner-regexp
										"name\=\")([^\"]*?)(?:\".*?\>)"))
								html-str)
							(rxmatch
								(string->regexp
									(string-append "(?i:\<"
										inner-regexp
										"name\=\')([^\']*?)(?:\'.*?\>)"))
								html-str)
							(rxmatch
								(string->regexp
									(string-append "(?i:\<"
										inner-regexp
										"name\=)([^ ]*?)(?:\s*?.*?\>)"))
								html-str))))
					(if
						form-match
						(rxmatch-substring form-match 1)
						""))))

		(
			checked-clear
			(lambda
				(html-str)
				(regexp-replace-all
					(string->regexp "(?i:[ ]checked)")
					html-str
					"")))
		(
			selected-clear
			(lambda
				(html-str)
				(regexp-replace-all
					(string->regexp "(?i:[ ]selected)")
					html-str
					"")))
		(
			value-clear
			(lambda
				(html-str)
				(regexp-replace-all
					(string->regexp "(?i:value=(\"[^\"]*?\"|\'[^\']*?\'|[^ ]*?))")
					html-str
					"")))

		(
			form-type-get
			(lambda
				(html-str)
					(cond
					((rxmatch
						(string->regexp
							"(?i:[ ]type=(\"|\'|)text(\"|\'|\s*?).*?)")
						html-str) "text")
					((rxmatch
						(string->regexp
							"(?i:[ ]type=(\"|\'|)password(\"|\'|\s*?).*?)")
						html-str) "password")
					((rxmatch
						(string->regexp
							"(?i:[ ]type=(\"|\'|)radio(\"|\'|\s*?).*?)")
						html-str) "radio")
					((rxmatch
						(string->regexp
							"(?i:[ ]type=(\"|\'|)checkbox(\"|\'|\s*?).*?)")
						html-str) "checkbox")
					((rxmatch
						(string->regexp
							"(?i:\<option[ ])")
						html-str) "option")
					((rxmatch
						(string->regexp
							"(?i:\<select[ ])")
						html-str) "select")
					((rxmatch
						(string->regexp
							"(?i:\<\/select)(?i:[ ]|\>)")
						html-str) "/select")
					((rxmatch
						(string->regexp
							"(?i:\<textarea[ ])")
						html-str) "textarea")
					((rxmatch
						(string->regexp
							"(?i:\<\/textarea)(?i:[ ]|\>)")
						html-str) "/textarea")
					(#t "none"))))



		(
			selected-set
			(lambda
				(html-str item-name form-param)
				(let
					((
						param-value
						(hash-table-get form-param item-name)))
				(if
					(list? param-value)
					(pickup-set-rec html-str param-value " selected")
					(pickup-set-rec html-str (list param-value) " selected")))))



		(
			checked-set
			(lambda
				(html-str item-name form-param)
				(let
					((
						param-value
						(hash-table-get form-param item-name)))
				(if
					(list? param-value)
					(pickup-set-rec html-str param-value " checked")
					(pickup-set-rec html-str (list param-value) " checked")))))

		(
			pickup-set-rec
			(lambda
				(html-str param-value sub-str)
				(if
					(null? param-value)
					html-str
					(begin
						(let
							((
								replaced-html-str
								(pickup-set
									html-str
									(car param-value)
									sub-str)))
						(if
							(not (string=? html-str replaced-html-str))
							replaced-html-str
							(pickup-set-rec
								html-str
								(cdr param-value)
								sub-str)))))))

		(
			pickup-set
			(lambda
				(html-str item-value inline-string)
				(let
					((
						form-match
						(or
							(rxmatch
								(string->regexp
									(string-append
									"(\<"
									inner-regexp
									"[vV][aA][lL][uU][eE]=\""
									(regexp-quote item-value)
									"\".*?)(\/?\>)"))
								html-str)
							(rxmatch
								(string->regexp
									(string-append
									"(\<"
									inner-regexp
									"[vV][aA][lL][uU][eE]=\'"
									(regexp-quote item-value)
									"\'.*?)(\/?\>)"))
								html-str)
							(rxmatch
								(string->regexp
									(string-append
									"(\<"
									inner-regexp
									"[vV][aA][lL][uU][eE]="
									(regexp-quote item-value)
									"\s*?.*?)(\/?\>)"))
								html-str))))


				(if
					form-match
					(string-append
						(rxmatch-substring form-match 1)
						inline-string
						(rxmatch-substring form-match 2))
					html-str))))

		(
			value-set
			(lambda
				(html-str item-name form-param)
				(let
					((
						form-match
						(rxmatch
							(string->regexp "(\<.*?)(\/?\>)")
							html-str)))
					(if
					form-match
					(string-append
						(rxmatch-substring form-match 1)
						" value=\""
						(hash-table-get form-param item-name)
						"\" "
						(rxmatch-substring form-match 2))
					html-str)))))




		 (form-fill
		 	(html-split body)
			form-param
			""
			""))))


(define-syntax
	html-form-fill
	(syntax-rules ()
		((_ e1  ((i1 v1) (i2 v2) ...))
			(make-param e1 ((i1 v1) (i2 v2) ...) (list)))))

(define-syntax
	make-param
	(syntax-rules ()
		((_ e1  () param-ls)
			(html-form-fill-by-hash-table
				e1
				(apply hash-table 'string=? param-ls))
			)
		((_ e1  ((i1 v1) (i2 v2) ...) param-ls)
			(make-param e1 ((i2 v2) ...) (cons (cons i1 v1) param-ls)))
		))


(provide "html-form-fill")