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

;; -*- mode: Scheme; tab-width: 2; -*- ;;
(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 <locale.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")

												 (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))))))]
								(registry-set! handle (cons new ((if old (cut remove! (cut pointer=? <> old) <>) identity) (registry handle))))))]
					 [callback
					  (lambda (handle name)
					  	(let ([proc (get/pointer handle name)])
					  		(cond
					  			[(wrapper-data proc) => cdr]
					  			[else proc])))])
		(values

           [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)])
	(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-lambda void "IupUnmap" nonnull-ihandle))
	(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-lambda ihandle "IupAppend" nonnull-ihandle nonnull-ihandle)]
           [insert! (foreign-lambda ihandle "IupInsert" nonnull-ihandle nonnull-ihandle nonnull-ihandle)])
  (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-lambda void "IupDetach" nonnull-ihandle))
	(foreign-safe-lambda void "IupDetach" nonnull-ihandle))

(define child-move!
	(letrec ([move! (foreign-lambda istatus "IupReparent" nonnull-ihandle nonnull-ihandle ihandle)])
	(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

;; }}}

;; {{{ 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* ([lang (or (getenv "LANG") "")]
               [(let ([status (dynamic-wind (cut setenv "LANG" "C") open (cut setenv "LANG" lang))])
		(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)))

;; }}}

)