IUP

;; {{{ Data types

(foreign-declare
	"#include <ffi.h>\n"
	"#include <locale.h>\n"
	"#include <im.h>\n"
	"#include <im_binfile.h>\n"
	"#include <iup.h>\n"
	"#include <iupim.h>\n"
	"typedef struct Iclass_ Iclass;\n"
	"struct Ihandle_ { char sig[4]; Iclass *iclass; /* ... */ } ;\n"
	"extern char *iupClassCallbackGetFormat(Iclass *iclass, const char *name);\n")

(define *ihandle-tag* "Ihandle")
(define ihandle? (cut tagged-pointer? <> *ihandle-tag*))

(define (ihandle->pointer nonnull?)
	(if nonnull?
		(lambda (handle)
			(ensure ihandle? handle)
			handle)
		(lambda (handle)
			(ensure (disjoin not ihandle?) handle)
			handle)))

(define (pointer->ihandle nonnull?)
	(if nonnull?
		(lambda (handle)
			(ensure pointer? handle)
			(tag-pointer handle *ihandle-tag*))
		(lambda (handle)
			(and handle (tag-pointer handle *ihandle-tag*)))))

(define (ihandle-list->pointer-vector lst)
	(let ([ptrs (make-pointer-vector (add1 (length lst)) #f)])
		(do-ec (:list handle (index i) lst)
			(begin
				(ensure ihandle? handle)
				(pointer-vector-set! ptrs i handle)))
		ptrs))

(define (istatus->integer status)
	(case status
		[(error)                 +1]
		[(opened invalid ignore) -1]
		[(default)               -2]
		[(close #f)              -3]
		[(continue)              -4]
		[else                    (if (integer? status) status 0)]))

(define (integer->istatus status)
	(case status
		[(+1) 'error]
		[( 0) #t]
		[(-1) 'ignore]
		[(-2) 'default]
		[(-3) #f]
		[(-4) 'continue]
		[else status]))

(define (iname->string default-case)
	(let ([change-case
	       (case default-case
	       	 [(upcase)   string-upcase]
	       	 [(downcase) string-downcase]
	       	 [else       (error 'iname->string "unsupported default case" default-case)])])
		(lambda (name)
			(cond
				[(or (not name) (string? name))
				 name]
				[(symbol? name)
				 (change-case (string-translate (symbol->string name) #\- #\_))]
				[else
				 (error 'iname->string "bad name" name)]))))

(define (string->iname default-case)
	(let ([specials
	       (irregex
	       	 (case default-case
	       	 	 [(upcase)   "[-a-z]"]
	       	 	 [(downcase) "[-A-Z]"]
	       	 	 [else       (error 'string->iname "unsupported default case" default-case)]))])
		(lambda (name)
			(cond
				[(or (not name) (irregex-search specials name))
				 name]
				[else
				 (string->symbol (string-downcase (string-translate name #\_ #\-)))]))))

(include "iup-types.scm")

;; }}}

;; {{{ Support macros and functions

(define-syntax :children
	(syntax-rules ()
		[(:children cc child handle)
		 (:do cc ([child (child-ref handle 0)]) child ((sibling child)))]))

(define-syntax optional-args
	(syntax-rules ()
		[(optional-args [name default] ...)
		 (lambda (args) (let-optionals args ([name default] ...) (list name ...)))]))

(define ((make-constructor-procedure proc #!key [apply-args values]) . args)
	(let more ([keys '()] [key-args '()] [pos-args '()] [rest args])
		(cond
			[(null? rest)
			 (let ([handle (apply proc (apply-args (reverse! pos-args)))])
			 	 (do-ec (:parallel (:list key keys) (:list arg key-args))
			 	 	 ((if (procedure? arg) callback-set! attribute-set!) handle key arg))
			 	 handle)]
			[(keyword? (car rest))
			 (more
			 	 (cons (car rest) keys) (cons (cadr rest) key-args) pos-args
			 	 (cddr rest))]
			[else
			 (more
			 	 keys key-args (cons (car rest) pos-args)
			 	 (cdr rest))])))

;; }}}

;; {{{ System functions

(define iup-version
	(foreign-lambda c-string "IupVersion"))

(define load/led
	(letrec ([load/raw (foreign-lambda c-string "IupLoad" c-string)])
		(lambda (file)
			(and-let* ([status (load/raw file)])
				(error 'load/led status))
			(void))))

;; }}}

;; {{{ Attribute functions

(define attribute-set!
  (letrec ([set/string! (foreign-safe-lambda void "IupStoreAttribute" ihandle iname/upcase c-string)]
           [set/handle! (foreign-safe-lambda void "IupSetAttributeHandle" ihandle iname/upcase ihandle)])
    (lambda (handle name value)
    	(cond
    		[(or (not value) (string? value))
         (set/string! handle name value)]
        [(ihandle? value)
         (set/handle! handle name value)]
        [(boolean? value)
         (set/string! handle name (if value "YES" "NO"))]
        [else
         (set/string! handle name (->string value))]))))

(define attribute-reset!
	(foreign-safe-lambda void "IupResetAttribute" ihandle iname/upcase))

(define attribute
  (getter-with-setter
  	(foreign-safe-lambda c-string "IupGetAttribute" ihandle iname/upcase)
  	attribute-set!))

(define attributes
	(foreign-primitive scheme-object ([ihandle handle])
		"int n = IupGetAllAttributes(handle, NULL, 0);"
		"if (n > 0) {"
		"  char **buf = (char **) alloca(n * sizeof(char *));"
		"  if (IupGetAllAttributes(handle, buf, n) == n) {"
		"    int i, m = C_SIZEOF_LIST(n);"
		"    for (i = 0; i < n; ++i) m += C_SIZEOF_STRING(strlen(buf[i]));"
		"    C_word *mrk = C_alloc(m), lst = C_SCHEME_END_OF_LIST;"
		"    for (i = n-1; i >= 0; --i) lst = C_pair(&mrk, C_string2(&mrk, buf[i]), lst);"
		"    C_return(lst);"
		"  }"
		"}"
		"C_return(C_SCHEME_END_OF_LIST);"))

(define handle-name-set!
	(letrec ([handle-set! (foreign-lambda ihandle "IupSetHandle" iname/downcase ihandle)])
		(lambda (handle name)
			(handle-set! (or name (handle-name handle)) (and name handle)))))

(define handle-name
  (getter-with-setter
  	(foreign-lambda iname/downcase "IupGetName" nonnull-ihandle)
  	handle-name-set!))

(define handle-ref
	(foreign-lambda ihandle "IupGetHandle" iname/downcase))

;; }}}

;; {{{ Event functions

(define main-loop
	(letrec ([loop (foreign-safe-lambda istatus "IupMainLoop")])
		(lambda ()
			(let ([status (loop)])
				(case status
					[(#t) (void)]
					[else (error 'main-loop (format "error in IUP main loop (~s)" status))])))))

(define main-loop-step
  (letrec ([loop-step (foreign-safe-lambda istatus "IupLoopStep")]
           [loop-step/wait (foreign-safe-lambda istatus "IupLoopStepWait")])
    (lambda (poll?)
      (let ([status ((if poll? loop-step loop-step/wait))])
        (case status
          [(error) (error 'main-loop-step "error in IUP main loop")]
          [else    status])))))

(define main-loop-level
	(foreign-lambda int "IupMainLoopLevel"))

(define main-loop-exit
	(foreign-lambda void "IupExitLoop"))

(define main-loop-flush
	(foreign-safe-lambda void "IupFlush"))

(define (make-wrapper cif)
  (let-location ([proc c-pointer #f])
    (let ([closure
           ((foreign-lambda* (c-pointer "ffi_closure") ([(nonnull-c-pointer c-pointer) proc])
              "C_return(ffi_closure_alloc(sizeof(ffi_closure), proc));" )
            (location proc))])
      (unless (and closure proc)
        (error 'callback-set! "failed to allocate closure"))
      (unless (zero?
               ((foreign-lambda* int ([(nonnull-c-pointer "ffi_closure") closure]
                                      [nonnull-c-pointer proc]
                                      [(nonnull-c-pointer "ffi_cif") cif])
                  "C_return(ffi_prep_closure_loc(closure, cif, &callback_entry, proc, proc));")
                closure proc cif))
        (error 'callback-set! "failed to initialize closure"))
      (values closure proc))))

(define (wrapper-id proc)
  (and proc (pointer->address proc)))

(define wrapper-destroy!
  (foreign-lambda void "ffi_closure_free" (nonnull-c-pointer "ffi_closure")))

(define-values (registry-ref registry-add! registry-remove! registry-clear!)
	(let ([registry (make-hash-table = number-hash)])
		(values
		 (lambda (id)
			 (cdr (hash-table-ref registry id)))
		 (lambda (handle cif data)
       (let*-values ([(closure proc) (make-wrapper cif)]
                     [(id) (pointer->address proc)])
         (hash-table-set!
          registry id
          (cons closure data))
         (hash-table-update!/default
          registry (pointer->address handle)
          (cut cons id <>) '())
         proc))
		 (lambda (handle proc)
			 (cond
				[(wrapper-id proc)
				 => (lambda (id)
							(hash-table-update!/default
							 registry (pointer->address handle)
							 (cut delete id <> =) '())
              (let ([closure (car (hash-table-ref registry id))])
                (hash-table-delete! registry id)
                (wrapper-destroy! closure)))]))
		 (lambda (handle)
			 (let* ([key (pointer->address handle)]
							[ids (hash-table-ref/default registry key '())])
				 (hash-table-delete! registry key)
				 (do-ec (:list id ids)
					 (let ([closure (car (hash-table-ref registry id))])
						 (hash-table-delete! registry id)
						 (wrapper-destroy! closure))))))))

(define call-interface
  (let ([interfaces (make-hash-table string=? string-hash)])
    (lambda (sig)
      (or
        (hash-table-ref/default interfaces sig #f)
        (let ([cif
               ((foreign-lambda* c-pointer ([size_t nsig] [(nonnull-scheme-pointer "const char") sig])
                  "typedef struct { ffi_cif cif; ffi_type *sig[1]; } pkg_t;"
                  "pkg_t *pkg = (pkg_t *)malloc(sizeof(pkg_t) + (nsig-1) * sizeof(ffi_type *));"
                  "for (size_t i = 0; i < nsig; ++i) {"
                  "  switch (sig[i]) {"
                  "  case 'b':"
                  "    pkg->sig[i] = &ffi_type_uint8;"
                  "    break;"
                  "  case 'i':"
                  "    pkg->sig[i] = &ffi_type_sint;"
                  "    break;"
                  "  case 'f':"
                  "    pkg->sig[i] = &ffi_type_float;"
                  "    break;"
                  "  case 'd':"
                  "    pkg->sig[i] = &ffi_type_double;"
                  "    break;"
                  "  case 's':"
                  "  case 'v':"
                  "  case 'C':"
                  "  case 'h':"
                  "    pkg->sig[i] = &ffi_type_pointer;"
                  "    break;"
                  "  default:"
                  "    pkg->sig[i] = &ffi_type_void;"
                  "    break;"
                  "  }"
                  "}"
                  "if (ffi_prep_cif(&pkg->cif, FFI_DEFAULT_ABI, nsig-1, pkg->sig[0], &pkg->sig[1]) != FFI_OK) {"
                  "  free(pkg); pkg = NULL;"
                  "}"
                  "C_return(pkg ? &pkg->cif : NULL);")
                (string-length sig) sig)])
          (unless cif
            (error 'callback-set! "unsupported signature"))
          (hash-table-set! interfaces sig cif)
          cif)))))

(define-external (callback_entry [(c-pointer "ffi_cif") cif] [c-pointer pret] [(c-pointer c-pointer) args] [c-pointer proc]) void
	(define frame-arg/ubyte!
		(foreign-lambda* unsigned-byte ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(uint8_t *)args[i]);"))
	(define frame-arg/int!
		(foreign-lambda* int ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(int *)args[i]);"))
	(define frame-arg/float!
		(foreign-lambda* float ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(float *)args[i]);"))
	(define frame-arg/double!
		(foreign-lambda* double ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(double *)args[i]);"))
	(define frame-arg/string!
		(foreign-lambda* c-string ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(const char **)args[i]);"))
	(define frame-arg/pointer!
		(foreign-lambda* c-pointer ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(void **)args[i]);"))
	(define frame-arg/handle!
		(foreign-lambda* ihandle ([(c-pointer c-pointer) args] [size_t i]) "C_return(*(Ihandle **)args[i]);"))

	(define frame-return/ubyte!
		(foreign-lambda* void ([c-pointer ret] [unsigned-byte v]) "*(uint8_t *)ret = v;"))
	;(define frame-return/int!
	;	(foreign-lambda* void ([c-pointer ret] [int v]) "*(int *)ret = v;"))
	(define frame-return/status!
		(foreign-lambda* void ([c-pointer ret] [istatus v]) "*(int *)ret = v;"))
	(define frame-return/float!
		(foreign-lambda* void ([c-pointer ret] [float v]) "*(float *)ret = v;"))
	(define frame-return/double!
		(foreign-lambda* void ([c-pointer ret] [double v]) "*(double *)ret = v;"))
	(define frame-return/pointer!
		(foreign-lambda* void ([c-pointer ret] [c-pointer v]) "*(void **)ret = v;"))
	(define frame-return/handle!
		(foreign-lambda* void ([c-pointer ret] [ihandle v]) "*(Ihandle **)ret = v;"))
	
	(call-with-current-continuation
	 (lambda (return)
		 (let ([sig "i"] [ret? #f])
			 (dynamic-wind
				 void
				 (lambda ()
					 (let* ([data (registry-ref (wrapper-id proc))]
									[proc (cdr data)])
						 (set! sig (car data))
						 (let ([args (list-ec (:string chr (index i) (string-drop sig 1))
													 (case chr
														 [(#\b)     (frame-arg/ubyte! args i)]
														 [(#\i)     (frame-arg/int! args i)]
														 [(#\f)     (frame-arg/float! args i)]
														 [(#\d)     (frame-arg/double! args i)]
														 [(#\s)     (frame-arg/string! args i)]
														 [(#\v #\C) (frame-arg/pointer! args i)]
														 [(#\h)     (frame-arg/handle! args i)]))])
							 (handle-exceptions exn
								 (print-error-message exn (current-error-port) "Error: in callback")
								 (let ([ret (apply proc args)])
									 (case (string-ref sig 0)
										 [(#\b)     (frame-return/ubyte! pret ret)]
										 [(#\i)     (frame-return/status! pret ret)]
										 [(#\f)     (frame-return/float! pret ret)]
										 [(#\d)     (frame-return/double! pret ret)]
										 [(#\v #\C) (frame-return/pointer! pret ret)]
										 [(#\h)     (frame-return/handle! pret ret)])
									 (set! ret? #t))))))
				 (lambda ()
					 (unless ret?
						 (case (string-ref sig 0)
							 [(#\b)         (frame-return/ubyte! pret 0)]
							 [(#\i)         (frame-return/status! pret 'continue)]
							 [(#\f)         (frame-return/float! pret 0.0)]
							 [(#\d)         (frame-return/double! pret 0.0)]
							 [(#\v #\C #\h) (frame-return/pointer! pret #f)]))
					 (return (void))))))))

(define-values (callback-set! callback)
	(letrec ([signature/raw
						(foreign-lambda* c-string ([nonnull-ihandle handle] [iname/upcase name])
							"C_return(iupClassCallbackGetFormat(handle->iclass, name));")]
					 [set/pointer!
					  (foreign-lambda c-pointer "IupSetCallback" nonnull-ihandle iname/upcase c-pointer)]
					 [get/pointer
					  (foreign-lambda c-pointer "IupGetCallback" nonnull-ihandle iname/upcase)]
					 [sigils
					  (irregex "([bifdsvCh]*)(?:=([bifdvCh]))?")]
					 [callback-set!
					  (lambda (handle name proc)
					  	(let* ([sig
					  	        (cond
												[(irregex-match sigils (or (signature/raw handle name) ""))
												 => (lambda (groups)
															(string-append
																(or (irregex-match-substring groups 2) "i")
																"h" (irregex-match-substring groups 1)))]
												[else
												 (error 'callback-set! "callback has bad signature" handle name)])]
					  			   [new
					  	        (cond
					  	        	[(or (not proc) (pointer? proc)) proc]
					  	        	[else (registry-add! handle (call-interface sig) (cons sig proc))])])
								(cond
								 [(set/pointer! handle name new) =>
									(cut registry-remove! handle <>)])))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-id proc)
									 => (lambda (id)
												(cdr (registry-ref id)))]
					  			[else proc])))])
		(values
			callback-set!
			(getter-with-setter callback callback-set!))))

;; }}}

;; {{{ Layout functions

(define create
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupCreate" iname/downcase)))

(define destroy!
  (letrec ([collect-handles
            (lambda (handle acc)
							(cons
							 handle
							 (fold-ec acc (:children child handle)
								 child collect-handles)))]
           [handle-destroy!
            (foreign-safe-lambda void "IupDestroy" nonnull-ihandle)])
    (lambda (handle)
			(let ([handles (collect-handles handle '())])
				(handle-destroy! handle)
				(main-loop-flush)
				(for-each registry-clear! handles)))))

(define map-peer!
	(letrec ([map-peer/raw! (foreign-safe-lambda istatus "IupMap" nonnull-ihandle)])
		(lambda (handle)
			(let ([status (map-peer/raw! handle)])
				(case status
					[(#t) (void)]
					[else (error 'map-peer! (format "failed to map peer (~s)" status) handle)])))))

(define unmap-peer!
	(foreign-safe-lambda void "IupUnmap" nonnull-ihandle))

(define class-name
	(foreign-lambda iname/downcase "IupGetClassName" nonnull-ihandle))

(define class-type
	(foreign-lambda iname/downcase "IupGetClassType" nonnull-ihandle))

(define save-attributes!
	(foreign-lambda void "IupSaveClassAttributes" nonnull-ihandle))

(define parent
	(foreign-lambda ihandle "IupGetParent" nonnull-ihandle))

(define parent-dialog
	(foreign-lambda ihandle "IupGetDialog" nonnull-ihandle))

(define sibling
	(foreign-lambda ihandle "IupGetBrother" nonnull-ihandle))

(define child-add!
  (letrec ([append! (foreign-safe-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)]
           [insert! (foreign-safe-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)])
    (lambda (child container #!optional [anchor #f])
      (or (if anchor
              (insert! container anchor child)
              (append! container child))
					(error 'child-add! "failed to add child" child container anchor)))))

(define child-remove!
	(foreign-safe-lambda void "IupDetach" nonnull-ihandle))

(define child-move!
	(letrec ([move! (foreign-safe-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)])
		(lambda (child parent #!optional ref-child)
			(let ([status (move! child parent ref-child)])
				(case status
					[(#t) (void)]
					[else (error 'child-move! (format "failed to move child (~s)" status) child parent)])))))

(define child-ref
  (letrec ([ref/position (foreign-lambda ihandle "IupGetChild" nonnull-ihandle int)]
           [ref/name (foreign-lambda ihandle "IupGetDialogChild" nonnull-ihandle iname/upcase)])
    (lambda (container id)
      ((if (integer? id) ref/position ref/name) container id))))

(define child-pos
	(letrec ([pos/raw (foreign-lambda int "IupGetChildPos" nonnull-ihandle nonnull-ihandle)])
		(lambda (parent child)
			(let ([pos (pos/raw parent child)])
				(and (not (negative? pos)) pos)))))

(define child-count
	(foreign-lambda int "IupGetChildCount" nonnull-ihandle))

(define (children handle)
	(list-ec (:children child handle) child))

(define refresh
	(foreign-safe-lambda void "IupRefresh" nonnull-ihandle))

(define redraw
	(letrec ([update
	          (foreign-safe-lambda* void ([nonnull-ihandle handle] [bool children])
	          	"IupUpdate(handle); if (children) IupUpdateChildren(handle);")]
	         [update/sync
	          (foreign-safe-lambda void "IupRedraw" nonnull-ihandle bool)])
	  (lambda (handle #!key [children? #f] [sync? #f])
	  	((if sync? update/sync update) handle children?))))

(define child-x/y->pos
	(letrec ([x/y->pos/raw (foreign-lambda int "IupConvertXYToPos" nonnull-ihandle int int)])
		(lambda (parent x y)
			(let ([pos (x/y->pos/raw parent x y)])
				(and (not (negative? pos)) pos)))))

;; }}}

;; {{{ Dialog functions

(define show
  (letrec ([position
            (lambda (v)
              (case v
                [(center)           #xffff]
                [(start top left)   #xfffe]
                [(end bottom right) #xfffd]
                [(mouse)            #xfffc]
                [(parent-center)    #xfffa]
                [(current)          #xfffb]
                [else               v]))]
           [popup (foreign-safe-lambda istatus "IupPopup" nonnull-ihandle int int)]
           [show/x/y (foreign-safe-lambda istatus "IupShowXY" nonnull-ihandle int int)])
    (lambda (handle #!key [x 'current] [y 'current] [modal? #f])
      (let ([status ((if modal? popup show/x/y) handle (position x) (position y))])
        (case status
          [(error) (error 'show "failed to show" handle)]
          [else    status])))))

(define hide
	(letrec ([hide/raw (foreign-safe-lambda istatus "IupHide" nonnull-ihandle)])
		(lambda (handle)
			(let ([status (hide/raw handle)])
				(case status
					[(#t) (void)]
					[else (error 'hide (format "failed to hide (~s)" status) handle)])))))

;; }}}

;; {{{ Composition functions

(define dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupDialog" ihandle)))

(define fill
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupFill")))

(define gridbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupGridBoxv((Ihandle **)handles));")
  	#:apply-args list))

(define hbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupHboxv((Ihandle **)handles));")
  	#:apply-args list))

(define vbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupVboxv((Ihandle **)handles));")
  	#:apply-args list))

(define zbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupZboxv((Ihandle **)handles));")
  	#:apply-args list))

(define cbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupCboxv((Ihandle **)handles));")
  	#:apply-args list))

(define sbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupSbox" ihandle)))

(define radio
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupRadio" ihandle)))

(define normalizer
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupNormalizerv((Ihandle **)handles));")
  	#:apply-args list))

(define backgroundbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupBackgroundBox" ihandle)))

(define detachbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupDetachBox" ihandle)))

(define expandbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupExpander" ihandle)))

(define scrollbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupScrollBox" ihandle)))

(define split
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupSplit" ihandle ihandle)))

;; }}}

;; {{{ Image resource functions

(define image/palette
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupImage" int int blob)))

(define image/rgb
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupImageRGB" int int blob)))

(define image/rgba
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupImageRGBA" int int blob)))

(define image/file
	(letrec ([load-image (foreign-lambda ihandle "IupLoadImage" c-string)])
		(make-constructor-procedure
			(lambda (file)
				(or (load-image file) (error 'image/file (attribute #f 'iupim-lasterror)))))))

(define image/blob
	(letrec ([load-image
						(foreign-lambda* ihandle ([scheme-pointer data] [int size])
							"Ihandle *image;"
							"imBinMemoryFileName file;"
							"int oldModule = imBinFileSetCurrentModule(IM_MEMFILE);"
							"file.buffer = data;"
							"file.size = size;"
							"file.reallocate = 0;"
							"image = IupLoadImage((const char *)&file);"
							"imBinFileSetCurrentModule(oldModule);"
							"C_return(image);")])
		(make-constructor-procedure
			(lambda (data)
				(or (load-image
						 data
						 (cond
							[(blob? data) (blob-size data)]
							[(string? data) (string-length data)]
							[else (error 'image/blob "unknown argument type")]))
						(error 'image/blob (attribute #f 'iupim-lasterror)))))))

(define image-save
	(letrec ([save-image (foreign-lambda bool "IupSaveImage" nonnull-ihandle c-string iname/upcase)])
		(lambda (handle file format)
			(unless (save-image handle file format)
				(error 'image-save (attribute #f 'iupim-lasterror))))))

;; }}}

;; {{{ Focus functions

(define current-focus
  (letrec ([focus (foreign-safe-lambda ihandle "IupGetFocus")]
           [focus-set! (foreign-safe-lambda ihandle "IupSetFocus" ihandle)]
           [current-focus
            (case-lambda
              [()       (focus)]
              [(handle) (focus-set! handle)])])
    (getter-with-setter current-focus current-focus)))

(define focus-next
	(letrec ([focus-next/raw (foreign-safe-lambda ihandle "IupNextField" ihandle)])
		(lambda (#!optional [handle (current-focus)])
			(focus-next/raw handle))))

(define focus-previous
	(letrec ([focus-previous/raw (foreign-safe-lambda ihandle "IupPreviousField" ihandle)])
		(lambda (#!optional [handle (current-focus)])
			(focus-previous/raw handle))))

;; }}}

;; {{{ Menu functions

(define menu
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupMenuv((Ihandle **)handles));")
  	#:apply-args list))

(define menu-item
  (letrec ([action-item (foreign-lambda nonnull-ihandle "IupItem" c-string iname/upcase)]
           [submenu-item (foreign-lambda nonnull-ihandle "IupSubmenu" c-string ihandle)])
    (make-constructor-procedure
     (lambda (#!optional [title #f] [action/menu #f])
       ((if (ihandle? action/menu) submenu-item action-item) title action/menu)))))

(define menu-separator
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupSeparator")))

;; }}}

;; {{{ Miscellaneous resource functions

(define clipboard
	(make-constructor-procedure
		(foreign-lambda nonnull-ihandle "IupClipboard")))

(define timer
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupTimer")))

(define send-url
	(letrec ([send-url/raw (foreign-lambda int "IupHelp" c-string)])
		(lambda (url)
			(and-let* ([status (send-url/raw url)]
			           [(not (= status 1))])
			  (error 'send-url (format "failed to open URL (~s)" status) url))
			(void))))

;; }}}

;; {{{ The library watchdog

(define thread-watchdog
  (letrec ([open (foreign-lambda* istatus () "C_return(IupOpen(NULL, NULL));")]
					 [setlocale (foreign-lambda* void () "setlocale(LC_NUMERIC, \"C\");")]
           [open-imglib (foreign-lambda void "IupImageLibOpen")]
           [close (foreign-lambda void "IupClose")]
           [chicken-yield (foreign-value "&CHICKEN_yield" c-pointer)])
		(and-let* ([(let ([status (dynamic-wind void open setlocale)])
    			        (case status
										[(#t)     #t]
										[(ignore) #f]
										[else     (error 'iup (format "failed to initialize library (~s)" status))]))]
      	       [(open-imglib)]
               [watchdog (timer)])
      (set-finalizer!
       watchdog
       (lambda (watchdog)
         (destroy! watchdog)
         (close)))
      (callback-set! watchdog 'action-cb chicken-yield)
      (attribute-set! watchdog 'time 500)
      (attribute-set! watchdog 'run #t)
      watchdog)))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iup_config.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Configuration component

(define config
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupConfig")))

(define (config-error location handle status)
	(let ([message
				 (case status
					 [(-1) "Error opening configuration file"]
					 [(-2) "Error accessing configuration file"]
					 [(-3) "Error locating configuration file"]
					 [else "Error concerning configuration file"])])
		(signal
		 (make-composite-condition
			(make-property-condition
			 'exn 'message message 'arguments (list handle) 'location location)
			(make-property-condition
			 'i/o)
			(make-property-condition
			 'config 'status status)))))

(define (config-load! handle)
	(let ([status ((foreign-lambda int "IupConfigLoad" nonnull-ihandle) handle)])
		(unless (zero? status) (config-error 'config-load! handle status))))

(define (config-save! handle)
	(let ([status ((foreign-lambda int "IupConfigSave" nonnull-ihandle) handle)])
		(unless (zero? status) (config-error 'config-save! handle status))))

;; }}}

;; {{{ Configured Dialog Positions

(define config-dialog-show
	(foreign-safe-lambda void "IupConfigDialogShow" nonnull-ihandle nonnull-ihandle nonnull-c-string))

(define config-dialog-update!
	(foreign-safe-lambda void "IupConfigDialogClosed" nonnull-ihandle nonnull-ihandle nonnull-c-string))

;; }}}

;; {{{ Configured Recent Files

(define-external (recent_action_entry [ihandle handle]) istatus
	(call-with-current-continuation
	 (lambda (return)
		 (let ([r 'continue])
			 (dynamic-wind
				 void
				 (lambda ()
					 (and-let* ([group (and handle (parent handle))]
											[action (callback group 'action)])
						 (handle-exceptions exn
							 (print-error-message exn (current-error-port) "Error: in recent action callback")
							 (set! r (action handle)))))
				 (lambda ()
					 (return r)))))))

(define config-recent-menu
	(make-constructor-procedure
	  (lambda (handle max-recent)
			(let ([menu (foreign-value "IupMenu(NULL)" nonnull-ihandle)])
				((foreign-lambda* void ([nonnull-ihandle handle] [nonnull-ihandle menu] [int max_recent])
					 "IupConfigRecentInit(handle, menu, recent_action_entry, max_recent);")
				 handle menu max-recent)
				menu))))

(define config-recent-update!
	(foreign-safe-lambda void "IupConfigRecentUpdate" nonnull-ihandle nonnull-c-string))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iupcontrols.h>\n")

(include "iup-types.scm")

;; }}}

;; {{{ Standard controls

(define canvas
	(make-constructor-procedure
		(foreign-lambda nonnull-ihandle "IupCanvas" iname/upcase)
		#:apply-args (optional-args [action #f])))

(define frame
	(make-constructor-procedure
		(foreign-lambda nonnull-ihandle "IupFrame" ihandle)
		#:apply-args (optional-args [child #f])))

(define tabs
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles])
  		"C_return(IupTabsv((Ihandle **)handles));")
  	#:apply-args list))

(define label
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupLabel" c-string)
  	#:apply-args (optional-args [title #f])))

(define link
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupLink" c-string c-string)
  	#:apply-args (optional-args [url #f] [title #f])))

(define button
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupButton" c-string iname/upcase)
  	#:apply-args (optional-args [title #f] [action #f])))

(define toggle
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupToggle" c-string iname/upcase)
  	#:apply-args (optional-args [title #f] [action #f])))

(define spin
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupSpin")))

(define spinbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupSpinbox" ihandle)))

(define valuator
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupVal" c-string)
  	#:apply-args (optional-args [type "HORIZONTAL"])))

(define textbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupText" iname/upcase)
  	#:apply-args (optional-args [action #f])))

(define listbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupList" iname/upcase)
  	#:apply-args (optional-args [action #f])))

(define treebox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupTree")))

(define calendar
  (make-constructor-procedure
    (foreign-lambda nonnull-ihandle "IupCalendar")))

(define date-picker
  (make-constructor-procedure
    (foreign-lambda nonnull-ihandle "IupDatePick")))

(define progress-bar
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupProgressBar")))

;; }}}

;; {{{ Extended controls

(define matrix
  (make-constructor-procedure
	  (lambda (action extended?)
			(if extended?
          ((foreign-lambda nonnull-ihandle "IupMatrixEx"))
          ((foreign-lambda nonnull-ihandle "IupMatrix" iname/upcase) action)))
  	#:apply-args (optional-args [action #f] [extended? #t])))

(define matrix-listbox
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupMatrixList")))

(define cells
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupCells")))

(define color-bar
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupColorbar")))

(define color-browser
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupColorBrowser")))

(define dial
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupDial" c-string)
  	#:apply-args (optional-args [type "HORIZONTAL"])))

;; }}}

;; {{{ Library setup

(let ([status (foreign-value "IupControlsOpen()" istatus)])
	(case status
		[(#t ignore) (void)]
		[else        (error 'iup "failed to initialize library (~s)" status)]))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Standard dialogs

(define file-dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupFileDlg")))

(define message-dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupMessageDlg")))

(define color-dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupColorDlg")))

(define font-dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupFontDlg")))

(define progress-dialog
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupProgressDlg")))

(define layout-dialog
	(make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupLayoutDialog" ihandle)
		#:apply-args (optional-args [dialog #f])))

(define element-properties-dialog
	(make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupElementPropertiesDialog" nonnull-ihandle)))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

(module iup-dynamic
	(iup-available? iup-dynamic-require)
	(import
    scheme
    (chicken base)
    (chicken condition))

(define (iup-dynamic-require sym)
	(eval `(begin (import iup) ,sym)))

(define (iup-available?)
	(condition-case ((iup-dynamic-require 'iup-version))
		[(exn) #f]))

)

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iupgl.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ GLCanvas control

(define glcanvas
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupGLCanvas" iname/upcase)
  	#:apply-args (optional-args [action #f])))

;; }}}

;; {{{ OpenGL context functions

(define call-with-glcanvas
  (letrec ([glcanvas-make-current (foreign-lambda void "IupGLMakeCurrent" nonnull-ihandle)]
           [glcanvas-swap-buffers (foreign-lambda void "IupGLSwapBuffers" nonnull-ihandle)]
           [glcanvas-wait (foreign-lambda void "IupGLWait" bool)])
    (lambda (handle proc #!key [swap? #f] [sync? #f])
      (dynamic-wind
       (lambda ()
         (glcanvas-make-current handle)
         (when sync? (glcanvas-wait #f)))
       (lambda ()
         (proc handle))
       (lambda ()
         (when swap? (glcanvas-swap-buffers handle))
         (when sync? (glcanvas-wait #t)))))))

(define glcanvas-is-current?
	(foreign-lambda bool "IupGLIsCurrent" nonnull-ihandle))

(define glcanvas-palette-set!
	(foreign-lambda void "IupGLPalette" nonnull-ihandle int float float float))

(define glcanvas-font-set!
	(foreign-lambda void "IupGLUseFont" nonnull-ihandle int int int))

;; }}}

;; {{{ Library setup

(foreign-code "IupGLCanvasOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iupglcontrols.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ GLCanvasBox and embedded controls

(define glcanvasbox
  (make-constructor-procedure
  	(foreign-lambda* nonnull-ihandle ([ihandle-list handles]) "C_return(IupGLCanvasBoxv((Ihandle **)handles));")
  	#:apply-args list))

(define glsubcanvas
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupGLSubCanvas")))

(define glframe
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLFrame" ihandle)))

(define glexpander
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLExpander" ihandle)))

(define glscrollbox
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLScrollBox" ihandle)))

(define glsizebox
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLSizeBox" ihandle)))

(define glseparator
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLSeparator")))

(define gllabel
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLLabel" c-string)
		#:apply-args (optional-args [title #f])))

(define gllink
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLLink" c-string c-string)
  	#:apply-args (optional-args [url #f] [title #f])))

(define glbutton
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLButton" c-string)
  	#:apply-args (optional-args [title #f])))

(define gltoggle
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLToggle" c-string)
  	#:apply-args (optional-args [title #f])))

(define glvaluator
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupGLVal")))

(define glprogress-bar
  (make-constructor-procedure
	  (foreign-lambda nonnull-ihandle "IupGLProgressBar")))

;; }}}

;; {{{ Library setup

(let ([status (foreign-value "IupGLControlsOpen()" istatus)])
	(case status
		[(#t ignore) (void)]
		[else        (error 'iup "failed to initialize library (~s)" status)]))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iup_mglplot.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ MglPlot controls

(define mglplot
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupMglPlot")))

(define mgllabel
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupMglLabel" c-string)
		#:apply-args (optional-args [title #f])))

;; }}}

;; {{{ Plotting functions

(define call-with-mglplot
  (letrec ([mglplot-begin (foreign-lambda void "IupMglPlotBegin" nonnull-ihandle int)]
           [mglplot-end (foreign-lambda void "IupMglPlotEnd" nonnull-ihandle)])
    (lambda (handle proc #!key [dimension 2])
      (dynamic-wind
       (lambda ()
         (mglplot-begin handle dimension))
       (lambda ()
         (proc handle))
       (lambda ()
         (mglplot-end handle))))))

(define mglplot-add!
  (letrec ([append/1d (foreign-lambda void "IupMglPlotAdd1D" nonnull-ihandle c-string double)]
					 [append/2d (foreign-lambda void "IupMglPlotAdd2D" nonnull-ihandle double double)]
					 [append/3d (foreign-lambda void "IupMglPlotAdd3D" nonnull-ihandle double double double)]
           [insert/1d (foreign-lambda* void ([nonnull-ihandle handle] [int index] [int sample_index] [c-string x] [double y]) "IupMglPlotInsert1D(handle, index, sample_index, (const char **) &x, &y, 1);")]
           [insert/2d (foreign-lambda* void ([nonnull-ihandle handle] [int index] [int sample_index] [double x] [double y]) "IupMglPlotInsert2D(handle, index, sample_index, &x, &y, 1);")]
           [insert/3d (foreign-lambda* void ([nonnull-ihandle handle] [int index] [int sample_index] [double x] [double y] [double z]) "IupMglPlotInsert3D(handle, index, sample_index, &x, &y, &z, 1);")]
           [current-index (lambda (handle) (string->number (attribute handle 'current)))])
    (lambda (handle x y #!optional [z #f] [sample-index #f] [index #f])
      (cond
			 [z
				(if sample-index
						(insert/3d handle (or index (current-index handle)) sample-index x y z)
						(append/3d handle x y z))]
			 [(string? x)
				(if sample-index
						(insert/1d handle (or index (current-index handle)) sample-index x y)
						(append/1d handle x y))]
			 [else
				(if sample-index
						(insert/2d handle (or index (current-index handle)) sample-index x y)
						(append/2d handle x y))]))))

(define mglplot-x/y/z->pixel-x/y
	(letrec ([transform (foreign-lambda void "IupMglPlotTransform" nonnull-ihandle double double double (c-pointer int) (c-pointer int))])
		(lambda (handle mglplot-x mglplot-y #!optional [mglplot-z 0.0])
			(let-location ([pixel-x int 0] [pixel-y int 0])
				(transform handle mglplot-x mglplot-y mglplot-z (location pixel-x) (location pixel-y))
				(values pixel-x pixel-y)))))

(define mglplot-paint-to
	(letrec ([paint-to (foreign-lambda void "IupMglPlotPaintTo" nonnull-ihandle nonnull-c-string int int double nonnull-c-string)])
		(lambda (handle format file #!optional [width 0] [height 0] [dpi 0.0])
			(paint-to handle format width height dpi file))))

;; }}}

;; {{{ Library setup

(foreign-code "IupMglPlotOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iupole.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Windows OLE control

(define ole-control
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupOleControl" nonnull-c-string)))

;; }}}

;; {{{ Library setup

(let ([status (foreign-value "IupOleControlOpen()" istatus)])
	(case status
		[(#t ignore) (void)]
		[else        (error 'iup "failed to initialize library (~s)" status)]))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iup_plot.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Plot control

(define plot
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupPlot")))

;; }}}

;; {{{ Plotting functions

(define call-with-plot
  (letrec ([plot-begin (foreign-lambda void "IupPlotBegin" nonnull-ihandle bool)]
           [plot-end (foreign-lambda void "IupPlotEnd" nonnull-ihandle)])
    (lambda (handle proc #!key [x-string? #f])
      (dynamic-wind
       (lambda ()
         (plot-begin handle x-string?))
       (lambda ()
         (proc handle))
       (lambda ()
         (plot-end handle))))))

(define plot-add!
  (letrec ([append/real (foreign-lambda void "IupPlotAdd" nonnull-ihandle double double)]
           [append/string (foreign-lambda void "IupPlotAddStr" nonnull-ihandle c-string double)]
           [insert/real (foreign-lambda void "IupPlotInsert" nonnull-ihandle int int double double)]
           [insert/string (foreign-lambda void "IupPlotInsertStr" nonnull-ihandle int int c-string double)]
           [current-index (lambda (handle) (string->number (attribute handle 'current)))])
    (lambda (handle x y #!optional [sample-index #f] [index #f])
      (if (string? x)
          (if sample-index
              (insert/string handle (or index (current-index handle)) sample-index x y)
              (append/string handle x y))
          (if sample-index
              (insert/real handle (or index (current-index handle)) sample-index x y)
              (append/real handle x y))))))

(define plot-x/y->pixel-x/y
	(letrec ([transform (foreign-lambda void "IupPlotTransform" nonnull-ihandle double double (c-pointer double) (c-pointer double))])
		(lambda (handle plot-x plot-y)
			(let-location ([pixel-x int 0] [pixel-y int 0])
				(transform handle plot-x plot-y (location pixel-x) (location pixel-y))
				(values pixel-x pixel-y)))))

(define plot-paint-to
	(foreign-lambda void "IupPlotPaintTo" nonnull-ihandle nonnull-c-pointer))

;; }}}

;; {{{ Library setup

(foreign-code "IupPlotOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iup_pplot.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ PPlot control

(define pplot
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupPPlot")))

;; }}}

;; {{{ Plotting functions

(define call-with-pplot
  (letrec ([pplot-begin (foreign-lambda void "IupPPlotBegin" nonnull-ihandle bool)]
           [pplot-end (foreign-lambda void "IupPPlotEnd" nonnull-ihandle)])
    (lambda (handle proc #!key [x-string? #f])
      (dynamic-wind
       (lambda ()
         (pplot-begin handle x-string?))
       (lambda ()
         (proc handle))
       (lambda ()
         (pplot-end handle))))))

(define pplot-add!
  (letrec ([append/real (foreign-lambda void "IupPPlotAdd" nonnull-ihandle float float)]
           [append/string (foreign-lambda void "IupPPlotAddStr" nonnull-ihandle c-string float)]
           [insert/real (foreign-lambda void "IupPPlotInsert" nonnull-ihandle int int float float)]
           [insert/string (foreign-lambda void "IupPPlotInsertStr" nonnull-ihandle int int c-string float)]
           [current-index (lambda (handle) (string->number (attribute handle 'current)))])
    (lambda (handle x y #!optional [sample-index #f] [index #f])
      (if (string? x)
          (if sample-index
              (insert/string handle (or index (current-index handle)) sample-index x y)
              (append/string handle x y))
          (if sample-index
              (insert/real handle (or index (current-index handle)) sample-index x y)
              (append/real handle x y))))))

(define pplot-x/y->pixel-x/y
	(letrec ([transform (foreign-lambda void "IupPPlotTransform" nonnull-ihandle float float (c-pointer int) (c-pointer int))])
		(lambda (handle pplot-x pplot-y)
			(let-location ([pixel-x int 0] [pixel-y int 0])
				(transform handle pplot-x pplot-y (location pixel-x) (location pixel-y))
				(values pixel-x pixel-y)))))

(define pplot-paint-to
	(foreign-lambda void "IupPPlotPaintTo" nonnull-ihandle nonnull-c-pointer))

;; }}}

;; {{{ Library setup

(foreign-code "IupPPlotOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iup_scintilla.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Scintilla text editor control

(define scintilla
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupScintilla")))

;; }}}

;; {{{ Library setup

(foreign-code "IupScintillaOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

(define-foreign-type ihandle (c-pointer "Ihandle")
	(ihandle->pointer #f)
	(pointer->ihandle #f))

(define-foreign-type ihandle-list nonnull-pointer-vector
	ihandle-list->pointer-vector)

(define-foreign-type nonnull-ihandle (nonnull-c-pointer "Ihandle")
	(ihandle->pointer #t)
	(pointer->ihandle #t))

(define-foreign-type istatus int
	istatus->integer
	integer->istatus)

(define-foreign-type iname/upcase c-string
	(iname->string 'upcase)
	(string->iname 'upcase))

(define-foreign-type iname/downcase c-string
	(iname->string 'downcase)
	(iname->string 'downcase))

;; vim: set ai et ts=2 sts=2 sw=2: ;;

;; {{{ Data types

(foreign-declare
	"#include <iup.h>\n"
	"#include <iupweb.h>\n")
	
(include "iup-types.scm")

;; }}}

;; {{{ Web browser control

(define web-browser
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupWebBrowser")))

;; }}}

;; {{{ Library setup

(foreign-code "IupWebBrowserOpen();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

((category ui)
 (synopsis "Bindings to the IUP GUI library")
 (author "Thomas Chust")
 (license "BSD")
 (version "1.9.1")
 (dependencies
   srfi-1 srfi-13 srfi-42 srfi-69
   miscmacros)
 (components
   (extension iup
     (modules
       iup
		   iup-base iup-controls iup-dialogs
			 iup-glcanvas
			 iup-glcontrols
			 iup-plot
			 iup-mglplot
			 iup-scintilla
			 iup-web
			 iup-config)
     (source-dependencies
       "iup-types.scm"
       "iup-base.scm" "iup-controls.scm" "iup-dialogs.scm"
       "iup-glcanvas.scm"
       "iup-glcontrols.scm"
       "iup-plot.scm"
       "iup-mglplot.scm"
       "iup-pplot.scm"
       "iup-scintilla.scm"
       "iup-web.scm"
       "iup-ole.scm"
       "iup-config.scm")
     (link-options
       "-L" "-lffi"
       "-L" "-liup"
       "-L" "-liupim"
       "-L" "-liupimglib"
       "-L" "-liupcontrols"
       "-L" "-liupgl"
       "-L" "-liupglcontrols"
       "-L" "-liup_plot"
       "-L" "-liup_mglplot"
       "-L" "-liup_scintilla"
       "-L" "-liupweb"))
   (extension iup-dynamic)))

;; vim: set ai et ts=2 sts=2 sw=2 ft=scheme: ;;

(module iup-base
	(ihandle->pointer pointer->ihandle ihandle-list->pointer-vector ihandle?
	 istatus->integer integer->istatus
	 iname->string string->iname
	 thread-watchdog iup-version load/led
	 attribute attributes attribute-set! attribute-reset!
	 handle-name handle-name-set! handle-ref
	 main-loop main-loop-step main-loop-level main-loop-exit main-loop-flush
	 callback callback-set!
	 make-constructor-procedure optional-args
	 create destroy! map-peer! unmap-peer!
	 class-name class-type save-attributes!
	 parent parent-dialog sibling
	 child-add! child-remove! child-move!
	 child-ref child-pos child-count
	 :children children
	 refresh redraw
	 child-x/y->pos
	 show hide
	 dialog
	 fill gridbox hbox vbox zbox cbox sbox
	 radio normalizer backgroundbox detachbox expandbox scrollbox split
	 image/palette image/rgb image/rgba image/file image/blob image-save
	 current-focus focus-next focus-previous
	 menu menu-item menu-separator
	 clipboard timer send-url)
	(import
		scheme
    (chicken base)
    (chicken gc)
    (chicken fixnum)
    (chicken blob)
    (chicken string)
    (chicken keyword)
    (chicken random)
    (chicken format)
    (chicken irregex)
    (chicken condition)
    (chicken memory)
    (chicken foreign)
		srfi-1 srfi-13 srfi-42 srfi-69
    miscmacros)
	(include "iup-base.scm"))

(module iup-controls
	(canvas
	 frame tabs
	 label link button toggle
	 spin spinbox valuator
	 textbox listbox treebox
   calendar date-picker
	 progress-bar
	 matrix matrix-listbox cells
	 color-bar color-browser
	 dial)
	(import
		scheme
    (chicken base)
    (chicken foreign)
		iup-base)
	(include "iup-controls.scm"))

(module iup-dialogs
	(file-dialog message-dialog color-dialog font-dialog progress-dialog
   layout-dialog element-properties-dialog)
	(import
		scheme
    (chicken base)
    (chicken foreign)
		iup-base)
	(include "iup-dialogs.scm"))

(cond-expand
 [disable-iup-glcanvas]
 [else
	(module iup-glcanvas
		(glcanvas
		 call-with-glcanvas glcanvas-is-current?
		 glcanvas-palette-set! glcanvas-font-set!)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-glcanvas.scm"))])

(cond-expand
 [(or disable-iup-glcanvas disable-iup-glcontrols)]
 [else
	(module iup-glcontrols
		(glcanvasbox glsubcanvas
		 call-with-glcanvas glcanvas-is-current?
		 glcanvas-palette-set! glcanvas-font-set!
		 glframe glexpander glscrollbox glsizebox
		 glseparator gllabel gllink glbutton gltoggle
		 glvaluator glprogress-bar)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base iup-glcanvas)
		(include "iup-glcontrols.scm"))])

(cond-expand
 [disable-iup-plot]
 [else
	(module iup-plot
		(plot
		 call-with-plot plot-add!
		 plot-x/y->pixel-x/y
		 plot-paint-to)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-plot.scm"))])

(cond-expand
 [disable-iup-mglplot]
 [else
	(module iup-mglplot
		(mglplot mgllabel
		 call-with-mglplot mglplot-add!
		 mglplot-x/y/z->pixel-x/y
		 mglplot-paint-to)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-mglplot.scm"))])

(cond-expand
 [enable-iup-pplot
	(module iup-pplot
		(pplot
		 call-with-pplot pplot-add!
		 pplot-x/y->pixel-x/y
		 pplot-paint-to)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-pplot.scm"))]
 [else])

(cond-expand
 [disable-iup-scintilla]
 [else
	(module iup-scintilla
		(scintilla)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-scintilla.scm"))])

(cond-expand
 [disable-iup-web]
 [else
	(module iup-web
		(web-browser)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-web.scm"))])

(cond-expand
 [enable-iup-ole
	(module iup-ole
		(ole-control)
		(import
		  scheme
      (chicken base)
      (chicken foreign)
			iup-base)
		(include "iup-ole.scm"))]
 [else])

(cond-expand
 [disable-iup-config]
 [else
	(module iup-config
		(config
		 config-load! config-save!
		 config-recent-menu config-recent-update!
		 config-dialog-show config-dialog-update!)
		(import
		  scheme
      (chicken base)
      (chicken condition)
      (chicken foreign)
			iup-base)
		(include "iup-config.scm"))])

(module iup
	()
	(import
    scheme
    (chicken base)
    (chicken module))
	(reexport
		(except iup-base
			ihandle->pointer pointer->ihandle ihandle-list->pointer-vector
			istatus->integer integer->istatus
			iname->string string->iname
			make-constructor-procedure optional-args)
		iup-controls
		iup-dialogs))

;; vim: set ai et ts=2 sts=2 sw=2: ;;