(module (libfyaml yaml2ss)
	(
		yaml<-
		yaml->ss
	)

(import
	scheme
	(chicken base)
	(chicken string)
	(chicken keyword)
	(chicken format)
	(chicken memory)
	(chicken irregex)
	(chicken foreign)
	(chicken condition)
)
(import varg)
(import
	(libfyaml libfyaml.h)
	(libfyaml if)
)

(foreign-declare "#include <libfyaml.h>")

(define-foreign-type enum int)

(define (string+ str . ..) (apply string-append (map ->string (cons str ..))))
(define (assoc* key alist) (cdr (assoc key alist)))
(define inerr "internal logic error, please contact maintainer")
(define string->number* (lambda (?)
	(if (string->number ?)
		(string->number ?)
		(abort (ycondition
			(sprintf "(string->number) convert error:\n~S" ?))))))
(define memset (foreign-lambda c-pointer "memset" c-pointer int size_t))
(define-syntax ycondition (syntax-rules ()
	((ycondition message others ...)
		(condition
			(list 'exn
				(string->symbol "message") message
				'call-chain (get-call-chain)
			)
			'(libfyaml) '(yaml->ss)
			others ...
		))
	((ycondition message)
		(condition
			(list 'exn
				(string->symbol "message") message
				'call-chain (get-call-chain)
			)
			'(libfyaml) '(yaml->ss)
		))
))
(define-syntax *-> (syntax-rules ()
	((*-> type-string pointer to-access ... return-type)
		(
			(foreign-lambda* return-type (((c-pointer type-string) _p))
				"C_return((_p)->" to-access ... ");")
			pointer
		))
))
(define (scalar->ss scalar)
	(cond
		; Regular expression is from https://yaml.org/spec/1.2.2/
		((or (= (string-length scalar) 0) (irregex-match? "null|Null|NULL|~" scalar))
			'())
		((irregex-match? "true|True|TRUE|false|False|FALSE" scalar)
			(let* ((^ (char-downcase (string-ref scalar 0))))
				(cond ((char=? ^ #\f) #f) ((char=? ^ #\f) #f) ((char=? ^ #\t) #t))))
		(
			(or
				(irregex-match? "[-+]?[0-9]+" scalar)
				(irregex-match?
					"[-+]?(\\.[0-9]+|[0-9]+(\\.[0-9]*)?)([eE][-+]?[0-9]+)?" scalar)
			) (string->number* scalar))
		(
			(or
				(irregex-match? "0o[0-7]+" scalar)
				(irregex-match? "0x[0-9a-fA-F]+" scalar)
			) (string->number* (string-append "#" (substring scalar 1))))
		((irregex-match? "[-+]?(\\.inf|\\.Inf|\\.INF)" scalar)
			(let ((sign (not (char=? #\. (string-ref scalar 0)))))
				(string->number* (string-append
					(if sign (substring scalar 0 1) "+")
					(list->string
						(map char-downcase (string->list (substring scalar (if sign 2 1)))))
					".0"))))
		((irregex-match? "\\.nan|\\.NaN|\\.NAN" scalar)
			(string->number* (string-append
				"+"
				(list->string (map char-downcase (string->list (substring scalar 1))))
				".0")))
		(else (string-copy scalar))
	)
)

(define (yaml->ss . ..)
	(let*
			(
				(input (foldr
					(lambda (l r) (if (or (pair? l) (keyword? l)) l (cons l r)))
					'()
					..))
				(without-input (foldr
					(lambda (l r)
						(if (or (pair? l) (keyword? l))
							(cons l r)
							r)
					) '() ..))
				(input (cond
					((> (length input) 1)
						(abort (ycondition (sprintf "multiple input:\n~S" input))))
					((= (length input) 1)
						(cons #:input (car input)))
					((= (length input) 0)
						(cons #:input (current-input-port)))
					(else (abort (ycondition "weird negative length list")))
				))
			)
		(apply with-fy-parser (cons input without-input))
	)
)
(define yaml<- yaml->ss)

(define (with-fy-parser . ..) (let
		(
			(parser (let ((parser (fy_parser_create #f)))
				(unless parser (abort (ycondition "fy_parser_create() failed")))
				parser))
		)
	(let
			(
				(yaml
					(call/cc (lambda (C) (with-exception-handler (lambda (e) (C e))
							(lambda() (apply parser->ss (cons `(#:parser . ,parser) ..)))
					))))
			)
		(fy_parser_destroy parser)
		(if (condition? yaml) ((current-exception-handler) yaml) yaml)
	)
))

(define (parser->ss . ..)
	(define vargs (varg ..
		'(#:with-value #:input #:parser)
		'(#:without-value)
		'(#:explicit #:input #:parser)
	))
	(define input (assoc* #:input (assoc* #:with-value vargs)))
	(define parser (assoc* #:parser (assoc* #:with-value vargs)))
	(let ((port->FILE* (foreign-lambda c-pointer "C_port_file" scheme-object)))
		(cond
			((string? input)
				(unless (= 0 (fy_parser_set_string
						parser input (string-length input)))
					(abort (ycondition "fy_parser_set_string() failed"))
				))
			((input-port? input)
				(unless (= 0 (fy_parser_set_input_fp parser
						"yaml2ss"
						;(port->FILE* input)
						;;libyaml cannot process port while libfyaml can
						input
					))
					(abort (ycondition "fy_parser_set_input_fp() failed"))
				))
			(else
				(abort (ycondition (sprintf
					"input is not a string or input-port:\n~S" input))))
		)
	)

	(let ((yaml (call/cc (lambda (C) (with-exception-handler
			(lambda (e)
				(C e))
		(lambda ()
			(define <anchor> (list))
			(define (event->type &event) (*-> "struct fy_event" &event "type" enum))
			(define-syntax let:ed (syntax-rules()
				((let:ed ((e d) <-event&data) todo ...)
					(let*
						(
							(event&data (<-event&data))
							(e (event->type (car event&data))) (d (cdr event&data))
						)
						(unless (= e FYET_NONE) (fy_parser_event_free parser (car event&data)))
						todo ...
					))))
			(define (<-event&data) (let*
				(
					(&event (fy_parser_parse parser))
					(event (event->type &event))
				)
				(cond
					((= event FYET_STREAM_START) (let()
						(define (<-ystream) (let:ed ((event data) <-event&data)
							(if (= event FYET_STREAM_END)
								(cons &event '())
								(let:ed ((se sd) <-ystream) (cons &event (cons data sd)))
							)
						))
						(<-ystream)
					))
					((= event FYET_DOCUMENT_START) (let()
						(define (<-ydoc) (let:ed ((event data) <-event&data)
							(if (= event FYET_DOCUMENT_END)
								(cons &event data)
								(let:ed ((de dd) <-ydoc) (cons &event data))
							)
						))
						(<-ydoc)
					))
					((= event FYET_MAPPING_START) (let()
						(define (<-ymap)
							(let:ed ((event key) <-event&data)
								(if (= event FYET_MAPPING_END)
									(cons &event '())
									(let:ed ((event value) <-event&data)
										(cons &event
											(cons (cons key value)
												(let:ed ((me md) <-ymap) md))))
							))
						)
						(let:ed ((me md) <-ymap) (cons &event (list md)))
					))
					((= event FYET_SEQUENCE_START) (let()
						(define (<-yseq) (let:ed ((event data) <-event&data)
							(if (= event FYET_SEQUENCE_END)
								(cons &event '())
								(let:ed ((se sd) <-yseq) (cons &event (cons data sd)))
							)
						))
						(let ((yseq (<-yseq))) (cons (car yseq) (list->vector (cdr yseq))))
					))
					((= event FYET_SCALAR)
						(cons &event (let (
								(token
									(*-> "struct fy_event_scalar_data"
										(fy_event_data &event) "value" c-pointer)))
							(if (= FYSS_PLAIN (fy_token_scalar_style token))
								(string->symbol (fy_token_get_text0 token))
								; XXX
								; Calling irregex-match? here with any arguments
								; will lead to stream end event from libfyaml.
								; Hence convert it to symbol here and
								; parse regular expression when it is symbol later.
								(fy_token_get_text0 token))))
					)
					(else (cons &event '()))
				)
			))
			(define (scalar-symbol->ss ?)
				(cond
					((vector? ?) (list->vector (map scalar-symbol->ss (vector->list ?))))
					((pair? ?) (cons (scalar-symbol->ss (car ?)) (scalar-symbol->ss (cdr ?))))
					((symbol? ?) (scalar->ss (symbol->string ?)))
					(else ?)
				))
			(let*
				(
					(document-list (scalar-symbol->ss (cdr (<-event&data))))
					(document-list (if (null? document-list) '(()) document-list))
					; empty file will not go into SCALAR event and get ~
				)
				(define (yaml . document-index)
					(cond
						((null? document-index) (list-ref document-list 0))
						((> (length document-index) 1)
							(abort (ycondition (sprintf
								"unknown arguments:\n~S" (cdr document-index)))))
						((= (length document-index) 1)
							(let ((i (car document-index)))
								(if (not (integer? i))
									(abort (ycondition (sprintf
										"document index is not a integer ~S" i))))
								(cond
									((>= i (length document-list))
										(abort (ycondition (sprintf
											"index ~S is lager then max document index ~S"
											i (- (length document-list) 1)))))
									((< i -1) (abort (ycondition (sprintf
										"invalid document index ~S" i))))
									((= i -1) document-list)
									(else (list-ref document-list i)))
							)
						)
						(else (abort (ycondition inerr)))
					))
				(unless (yaml? yaml) (abort (ycondition inerr '(yaml?))))
				yaml
			)
		))))))
		(if (condition? yaml) ((current-exception-handler) yaml) yaml)
	)
) ;define

) ;module