(require-library
	lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex posix)

(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 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 hbox vbox zbox cbox sbox
	 radio normalizer split
	 image/palette image/rgb image/rgba image/file image-save
	 current-focus focus-next focus-previous
	 menu menu-item menu-separator
	 clipboard timer send-url)
	(import
		scheme chicken foreign
		lolevel data-structures extras srfi-1 srfi-13 srfi-42 irregex
		(only posix setenv))

;; {{{ Data types

(foreign-declare
	"#include <callback.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 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-values (registry-set! registry registry-destroy!)
  (letrec ([registry-cell-set!
  					(foreign-lambda* void ([nonnull-ihandle handle] [c-pointer cell])
  						"IupSetAttribute(handle, \"CHICKEN_REGISTRY\", cell);")]
  				 [registry-cell
  				  (foreign-lambda* c-pointer ([nonnull-ihandle handle])
  				  	"C_return(IupGetAttribute(handle, \"CHICKEN_REGISTRY\"));")]
  				 [make-immobile-cell
  				  (foreign-lambda* nonnull-c-pointer ([scheme-object v])
  				  	"void *cell = CHICKEN_new_gc_root();\n"
  				  	"CHICKEN_gc_root_set(cell, v);\n"
  				  	"C_return(cell);\n")]
  				 [cell-destroy!
  				  (foreign-lambda void "CHICKEN_delete_gc_root" nonnull-c-pointer)]
  				 [cell-set!
  				  (foreign-lambda void "CHICKEN_gc_root_set" nonnull-c-pointer scheme-object)]
  				 [cell-ref
  				  (foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer)])
    (values
     (lambda (handle value)
       (cond
         [(registry-cell handle) => (cut cell-set! <> value)]
         [else (registry-cell-set! handle (make-immobile-cell value))]))
     (lambda (handle)
       (cond
         [(registry-cell handle) => cell-ref]
         [else '()]))
     (lambda (handle)
       (cond
         [(registry-cell handle)
          => (lambda (cell)
               (registry-cell-set! handle #f)
               (cell-destroy! cell))])))))

(define-external (callback_entry [c-pointer cell] [c-pointer frame]) void
	(define cell-ref
		(foreign-lambda scheme-object "CHICKEN_gc_root_ref" nonnull-c-pointer))
	
	(define frame-start/ubyte!
		(foreign-lambda* void ([c-pointer frame]) "va_start_uchar((va_alist)frame);"))
	(define frame-start/int!
		(foreign-lambda* void ([c-pointer frame]) "va_start_int((va_alist)frame);"))
	(define frame-start/float!
		(foreign-lambda* void ([c-pointer frame]) "va_start_float((va_alist)frame);"))
	(define frame-start/double!
		(foreign-lambda* void ([c-pointer frame]) "va_start_double((va_alist)frame);"))
	(define frame-start/pointer!
		(foreign-lambda* void ([c-pointer frame]) "va_start_ptr((va_alist)frame, void *);"))
	
	(define frame-arg/ubyte!
		(foreign-lambda* unsigned-byte ([c-pointer frame]) "C_return(va_arg_uchar((va_alist)frame));"))
	(define frame-arg/int!
		(foreign-lambda* int ([c-pointer frame]) "C_return(va_arg_int((va_alist)frame));"))
	(define frame-arg/float!
		(foreign-lambda* float ([c-pointer frame]) "C_return(va_arg_float((va_alist)frame));"))
	(define frame-arg/double!
		(foreign-lambda* double ([c-pointer frame]) "C_return(va_arg_double((va_alist)frame));"))
	(define frame-arg/string!
		(foreign-lambda* c-string ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, char *));"))
	(define frame-arg/pointer!
		(foreign-lambda* c-pointer ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, void *));"))
	(define frame-arg/handle!
		(foreign-lambda* ihandle ([c-pointer frame]) "C_return(va_arg_ptr((va_alist)frame, Ihandle *));"))
	
	(define frame-return/ubyte!
		(foreign-lambda* void ([c-pointer frame] [unsigned-byte ret]) "va_return_uchar((va_alist)frame, ret);"))
	;(define frame-return/int!
	;	(foreign-lambda* void ([c-pointer frame] [int ret]) "va_return_int((va_alist)frame, ret);"))
	(define frame-return/status!
		(foreign-lambda* void ([c-pointer frame] [istatus ret]) "va_return_int((va_alist)frame, ret);"))
	(define frame-return/float!
		(foreign-lambda* void ([c-pointer frame] [float ret]) "va_return_float((va_alist)frame, ret);"))
	(define frame-return/double!
		(foreign-lambda* void ([c-pointer frame] [double ret]) "va_return_double((va_alist)frame, ret);"))
	(define frame-return/pointer!
		(foreign-lambda* void ([c-pointer frame] [c-pointer ret]) "va_return_ptr((va_alist)frame, void *, ret);"))
	(define frame-return/handle!
		(foreign-lambda* void ([c-pointer frame] [ihandle ret]) "va_return_ptr((va_alist)frame, Ihandle *, ret);"))
	
	(let* ([data (cell-ref cell)]
				 [sig (car data)]
				 [proc (cdr data)])
		(case (string-ref sig 0)
			[(#\b)     (frame-start/ubyte! frame)]
			[(#\i)     (frame-start/int! frame)]
			[(#\f)     (frame-start/float! frame)]
			[(#\d)     (frame-start/double! frame)]
			[(#\v #\h) (frame-start/pointer! frame)])
		(let* ([args (list-ec (:string chr "h" (string-drop sig 1))
					         (case chr
					         	 [(#\b) (frame-arg/ubyte! frame)]
					         	 [(#\i) (frame-arg/int! frame)]
					         	 [(#\f) (frame-arg/float! frame)]
					         	 [(#\d) (frame-arg/double! frame)]
					         	 [(#\s) (frame-arg/string! frame)]
					         	 [(#\v) (frame-arg/pointer! frame)]
					         	 [(#\h) (frame-arg/handle! frame)]))]
				   [ret (apply proc args)])
			(case (string-ref sig 0)
				[(#\b) (frame-return/ubyte! frame ret)]
				[(#\i) (frame-return/status! frame ret)]
				[(#\f) (frame-return/float! frame ret)]
				[(#\d) (frame-return/double! frame ret)]
				[(#\v) (frame-return/pointer! frame ret)]
				[(#\h) (frame-return/handle! frame ret)]))))

(define-values (callback-set! callback)
	(letrec ([signature/raw
						(foreign-lambda* c-string ([nonnull-ihandle handle] [iname/upcase name])
							"C_return(iupClassCallbackGetFormat(handle->iclass, name));")]
					 [make-wrapper
					  (foreign-lambda* c-pointer ([scheme-object v])
					  	"void *cell = CHICKEN_new_gc_root();\n"
					  	"CHICKEN_gc_root_set(cell, v);\n"
					  	"C_return(alloc_callback(&callback_entry, cell));\n")]
					 [wrapper-data
	          (foreign-lambda* scheme-object ([c-pointer proc])
	          	"C_return((proc && is_callback(proc) ? CHICKEN_gc_root_ref(callback_data(proc)) : C_SCHEME_FALSE));")]
	         [wrapper-destroy!
	          (foreign-lambda* void ([c-pointer proc])
	          	"if (proc && is_callback(proc)) {\n"
	          	"  CHICKEN_delete_gc_root(callback_data(proc));\n"
	          	"  free_callback(proc);\n"
	          	"}\n")]
	         [wrapper->proc
	          (lambda (signature proc)
	          	(cond
	          		[(wrapper-data proc) => cdr]
	          		[else proc]))]
					 [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 "([bifdsvh]*)(?:=([bifdvh]))?")]
					 [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")
																(irregex-match-substring groups 1)))]
												[else
												 (error 'callback-set! "callback has bad signature" handle name)])]
					  			   [new
					  	        (cond
					  	        	[(or (not proc) (pointer? proc)) proc]
					  	        	[else (set-finalizer! (make-wrapper (cons sig proc)) wrapper-destroy!)])]
					  	       [old
					  	        (set/pointer! handle name new)])
								(registry-set! handle (cons new (remove! (cut pointer=? <> old) (registry handle))))))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-data proc) => cdr]
					  			[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 ([registry-destroy/recursive!
            (lambda (handle)
              (registry-destroy! handle)
              (do-ec (:children child handle)
                (registry-destroy/recursive! child)))]
           [handle-destroy!
            (foreign-lambda void "IupDestroy" nonnull-ihandle)])
    (lambda (handle)
      (registry-destroy/recursive! handle)
      (handle-destroy! handle))))

(define map-peer!
	(letrec ([map-peer/raw! (foreign-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-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-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)]
           [insert! (foreign-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-lambda void "IupDetach" nonnull-ihandle))

(define child-move!
	(letrec ([move! (foreign-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 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 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-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));")]
           [open-imglib (foreign-lambda void "IupImageLibOpen")]
           [close (foreign-lambda void "IupClose")]
           [chicken-yield (foreign-value "&CHICKEN_yield" c-pointer)])
		(and-let* ([lang (or (getenv "LANG") "")]
               [(let ([status (dynamic-wind (cut setenv "LANG" "C") open (cut setenv "LANG" lang))])
    			        (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)))

;; }}}

)

(require-library iup-base)

(module iup-controls
	(canvas
	 frame tabs
	 label button toggle
	 spin spinbox valuator
	 textbox listbox treebox
	 progress-bar
	 matrix cells
	 color-bar color-browser
	 dial)
	(import
		scheme chicken foreign
		iup-base)

;; {{{ 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 [action #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 [action #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 progress-bar
  (make-constructor-procedure
  	(foreign-lambda nonnull-ihandle "IupProgressBar")))

;; }}}

;; {{{ Extended controls

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

(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)]))

;; }}}

)

(require-library iup-base)

(module iup-dialogs
	(file-dialog message-dialog color-dialog font-dialog)
	(import
		scheme chicken foreign
		iup-base)

;; {{{ 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")))

;; }}}

)

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

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

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

)

(require-library iup-base)

(module iup-glcanvas
	(glcanvas
	 call-with-glcanvas glcanvas-is-current?
	 glcanvas-palette-set! glcanvas-font-set!)
	(import
		scheme chicken foreign
		iup-base)

;; {{{ 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();")

;; }}}

)

(require-library iup-base)

(module iup-pplot
	(pplot
	 call-with-pplot pplot-add!
	 pplot-x/y->pixel-x/y
	 pplot-paint-to)
	(import
		scheme chicken foreign
		iup-base)

;; {{{ 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 index
              (insert/string handle (or index (current-index handle)) sample-index x y)
              (append/string handle x y))
          (if 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();")

;; }}}

)

(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))

((category ui)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "Bindings to the IUP GUI library")
 (doc-from-wiki)
 (needs srfi-42))

(require-library iup-base iup-controls iup-dialogs)

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

;; -*- mode: Scheme; tab-width: 2; -*- ;;
(cond-expand
 [no-library-checks
	(define-syntax check-libraries
		(syntax-rules ()
			[(check-libraries [lib fun] ...)
			 #t]))]
 [else
	(define-syntax check-libraries
		(syntax-rules ()
			[(check-libraries [lib fun] ...)
			 (and (find-library lib fun) ...)]))])

(if (check-libraries
		  ["callback" "alloc_trampoline_r"]
			["iup" "IupOpen"]
			["iupim" "IupLoadImage"]
			["iupimglib" "IupImageLibOpen"])
	(begin
		(compile -s -O2 -d1 "iup-base.scm" -j iup-base "-lcallback -liup -liupim -liupimglib")
		(compile -c -O2 -d1 "iup-base.scm" -j iup-base -unit iup-base)
		(compile -s -O2 -d0 "iup-base.import.scm")
		
		(install-extension
		 'iup-base
		 '("iup-base.so" "iup-base.o" "iup-base.import.so" "iup-types.scm")
		 '((version 1.0.2)
			 (static "iup-base.o")
			 (static-options "-lcallback -liup -liupim -liupimglib")))
		
		(compile -s -O2 -d1 "iup-controls.scm" -j iup-controls "-liup -liupcontrols")
		(compile -c -O2 -d1 "iup-controls.scm" -j iup-controls -unit iup-controls)
		(compile -s -O2 -d0 "iup-controls.import.scm")
		
		(install-extension
		 'iup-controls
		 '("iup-controls.so" "iup-controls.o" "iup-controls.import.so")
		 '((version 1.0.2)
			 (static "iup-controls.o")
			 (static-options "-liup -liupcontrols")))
		
		(compile -s -O2 -d1 "iup-dialogs.scm" -j iup-dialogs "-liup")
		(compile -c -O2 -d1 "iup-dialogs.scm" -j iup-dialogs -unit iup-dialogs)
		(compile -s -O2 -d0 "iup-dialogs.import.scm")
		
		(install-extension
		 'iup-dialogs
		 '("iup-dialogs.so" "iup-dialogs.o" "iup-dialogs.import.so")
		 '((version 1.0.2)
			 (static "iup-dialogs.o")
			 (static-options "-liup")))
		
		(if (check-libraries ["iupgl" "IupGLCanvasOpen"])
			(begin
				(compile -s -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas "-liup -liupgl")
				(compile -c -O2 -d1 "iup-glcanvas.scm" -j iup-glcanvas -unit iup-glcanvas)
				(compile -s -O2 -d0 "iup-glcanvas.import.scm")
				
				(install-extension
				 'iup-glcanvas
				 '("iup-glcanvas.so" "iup-glcanvas.o" "iup-glcanvas.import.so")
				 '((version 1.0.2)
					 (static "iup-glcanvas.o")
					 (static-options "-liup -liupgl"))))
			(warning "IUP GLCanvas not found, some bindings cannot be compiled"))
		
		(if (check-libraries ["iup_pplot" "IupPPlotOpen"])
			(begin
				(compile -s -O2 -d1 "iup-pplot.scm" -j iup-pplot "-liup -liup_pplot")
				(compile -c -O2 -d1 "iup-pplot.scm" -j iup-pplot -unit iup-pplot)
				(compile -s -O2 -d0 "iup-pplot.import.scm")
				
				(install-extension
				 'iup-pplot
				 '("iup-pplot.so" "iup-pplot.o" "iup-pplot.import.so")
				 '((version 1.0.2)
					 (static "iup-pplot.o")
					 (static-options "-liup -liup_pplot"))))
			(warning "IUP PPlot not found, some bindings cannot be compiled"))
		
		(compile -s -O2 -d1 "iup.scm" -j iup)
		(compile -c -O2 -d1 "iup.scm" -j iup -unit iup)
		(compile -s -O2 -d0 "iup.import.scm")
		
		(install-extension
		 'iup
		 '("iup.so" "iup.o" "iup.import.so")
		 '((version 1.0.2)
			 (static "iup.o"))))
	(warning "IUP or ffcall not found, none of the bindings can be compiled"))

(compile -s -O2 -d1 "iup-dynamic.scm" -j iup-dynamic)
(compile -c -O2 -d1 "iup-dynamic.scm" -j iup-dynamic -unit iup-dynamic)
(compile -s -O2 -d0 "iup-dynamic.import.scm")

(install-extension
 'iup-dynamic
 '("iup-dynamic.so" "iup-dynamic.o" "iup-dynamic.import.so")
 '((version 1.0.2)
   (static "iup-dynamic.o")))

(let ([dlg (dialog #:title "Test" (button "Push me!" #:action print))]) 
  (show dlg #:modal? #t))