(module (libfyaml ss2yaml)
	(
		ss->yaml
	)

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

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

(define-foreign-type enum int)

(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-syntax ycondition (syntax-rules ()
	((ycondition message others ...)
		(condition
			(list 'exn
				(string->symbol "message") message
				'call-chain (get-call-chain)
			)
			'(libfyaml) '(<-yaml)
			others ...
		))
	((ycondition message)
		(condition
			(list 'exn
				(string->symbol "message") message
				'call-chain (get-call-chain)
			)
			'(libfyaml) '(<-yaml)
		))
))

(define (assoc* key alist) (cdr (assoc key alist)))
(define emitter-cfg (foreign-lambda* c-pointer ((int flags) (c-pointer fp))
	"
		static struct fy_emitter_xcfg xcfg;
		memset(&xcfg, 0, sizeof(xcfg));
		xcfg.cfg.flags = flags;
		xcfg.cfg.output = fy_emitter_default_output;
		xcfg.xflags = FYEXCF_COLOR_NONE|FYEXCF_OUTPUT_FILE;
		xcfg.output_fp = fp;
		C_return(&xcfg);
	"
))

(define (ss->yaml . ..) (apply with-fy-emitter ..))
(define (with-fy-emitter . ..)
	(define vargs (varg ..
		'(#:with-value #:flags #:output)
		#:enable-unknown
	))
	(define flags (let*
			(
				(flags (assoc #:flags (assoc* #:with-value vargs)))
				(flags (if flags (cdr flags) (list
					FYECF_INDENT_2
					FYECF_VERSION_DIR_OFF
					FYECF_MODE_BLOCK
					FYECF_WIDTH_INF
				)))
			)
		(apply bitwise-ior (cons  FYECF_EXTENDED_CFG flags))
	))
	(define output (let*
			(
				(output (assoc #:output (assoc* #:with-value vargs)))
				(output (if output (cdr output) (current-output-port)))
			)
		(unless (output-port? output)
			(abort (ycondition (sprintf "Not a output port:\n~S" output))))
		output
	))
	(define em (let*
			(
				(port->FILE* (foreign-lambda c-pointer "C_port_file" scheme-object))
				(em (fy_emitter_create (emitter-cfg flags (port->FILE* output))))
			)
		(if em em (abort (ycondition "fy_emitter_create() error")))
	))
	(let
			(
				(?condition (call/cc (lambda (C) (with-exception-handler (lambda (e) (C e))
					(lambda () (apply emitter->yaml (cons
						`(#:emitter . ,em)
						(assoc* #:literal vargs))))
				))))
			)
		(fy_emitter_destroy em)
		(if (condition? ?condition) ((current-exception-handler) ?condition))
	)
)

(define (integer->boolean i) (not (= i 0)))
(define (boolean->integer b) (if b 1 0))
(define-foreign-type c-bool int boolean->integer integer->boolean)
(define (emitter->yaml . ..)
	(define vargs (varg ..
		'(#:literal yaml)
		'(#:with-value #:port #:emitter)
		'(#:without-value #:strict-input)
		'(#:explicit #:emitter)
	))
	(define em (assoc* #:emitter (assoc* #:with-value vargs)))
	(define port (let
			((port (assoc #:port (assoc* #:with-value vargs))))
		(if port port (current-output-port))))
	(unless (output-port? port) (abort (ycondition
		"Not a output port:\n~S" port)))

	(define yaml (car (assoc* #:literal vargs)))

	(define (emit-event-create . ..) (let ((... (cons em ..)) (ev (car ..))) (cond
			((= ev FYET_STREAM_START)
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev))
						"C_return(fy_emit_event_create(em, ev));")
					...))
			((member ev (list FYET_STREAM_END FYET_MAPPING_END FYET_SEQUENCE_END))
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev))
						"C_return(fy_emit_event_create(em, ev));")
					...))
			((= ev FYET_DOCUMENT_START)
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev)(c-bool implicit))
						"C_return(fy_emit_event_create(em, ev, implicit, NULL, NULL));")
					...))
			((= ev FYET_DOCUMENT_END)
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev)(c-bool implicit))
						"C_return(fy_emit_event_create(em, ev, implicit));")
					...))
			((member ev (list FYET_MAPPING_START FYET_SEQUENCE_START))
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev)(int style))
						"C_return(fy_emit_event_create(em, ev, style, NULL, NULL));")
					...))
			((= ev FYET_SCALAR)
				(apply (foreign-lambda* c-pointer
						((c-pointer em)(int ev)(int style)(nonnull-c-string value))
						"C_return(fy_emit_event_create(em, ev, style, value, strlen(value),
						NULL, NULL));")
					...))
			(else
				(abort (ycondition (sprintf "Invalid type:\n~S" ev))))
	)))
	(define (ee . ..) (let*
			(
				(ev (apply emit-event-create ..))
				(fy_emit_event (fy_emit_event em ev))
			)
		(unless (= 0 fy_emit_event) (abort (ycondition (sprintf
			"fy_emit_event() error, return code:\n~S" fy_emit_event))))
	))

	(ee FYET_STREAM_START)

	(define (ss->ydoc y)
		(cond
			((null? y) (ee FYET_SCALAR FYSS_PLAIN "~"))
			((ymap? y)
				(ee FYET_MAPPING_START FYNS_BLOCK)
				(let ((alist (car y)))
					(map (lambda (?) (ss->ydoc (car ?)) (ss->ydoc (cdr ?))) alist))
				(ee FYET_MAPPING_END)
			)
			((ylist? y)
				(ee FYET_SEQUENCE_START FYNS_BLOCK)
				(let ((as-list (vector->list y)))
					(map ss->ydoc as-list))
				(ee FYET_SEQUENCE_END)
			)
			(else
				(cond
					((string? y) (let ((ys (yaml->ss y))) (let ((mode (cond
						((equal? ys y) FYSS_PLAIN)
						((> (length (string-split y "\n")) 1) FYSS_LITERAL)
						(else FYSS_LITERAL)
					))) (ee FYET_SCALAR mode y))))
					((number? y)
						(cond
							((nan? y) (let ((scalar ".nan"))
								(ee FYET_SCALAR FYSS_PLAIN scalar)
							))
							((infinite? y) (let ((scalar (if (> y 0) "+.inf" "-.inf")))
								(ee FYET_SCALAR FYSS_PLAIN scalar)
							))
							(else (let ((scalar (number->string y)))
								(ee FYET_SCALAR FYSS_PLAIN scalar)
							))
						))
					((boolean? y) (let ((scalar (if y "true" "false")))
						(ee FYET_SCALAR FYSS_PLAIN scalar)
					))
					(else
						(abort (ycondition
							(sprintf "Not a valid yaml format:\n~S" y)))
					)
				)
			)
		)
	)
	(cond
		((ydoc? yaml)
			(map (lambda (?)
				(ee FYET_DOCUMENT_START #f)
				(ss->ydoc ?)
				(ee FYET_DOCUMENT_END #f)
			) (yaml -1)))
		((ydoc? (lambda (^ . ..) yaml))
			(map (lambda (?)
				(ee FYET_DOCUMENT_START #t)
				(ss->ydoc ?)
				(ee FYET_DOCUMENT_END #t)
			) yaml))
		(else
			(ee FYET_DOCUMENT_START #t)
			(ss->ydoc yaml)
			(ee FYET_DOCUMENT_END #t)
		)
	)

	(ee FYET_STREAM_END)

)

) ;module