#lang racket
(require
srfi/2
srfi/17
srfi/26
ffi/unsafe)
(define-cpointer-type _ihandle)
(define _istatus
(make-ctype
_int
(λ (status)
(case status
[(error) +1]
[(opened invalid ignore) -1]
[(default) -2]
[(close #f) -3]
[(continue) -4]
[else (if (integer? status) status 0)]))
(λ (status)
(case status
[(+1) 'error]
[( 0) #t]
[(-1) 'ignore]
[(-2) 'default]
[(-3) #f]
[(-4) 'continue]
[else status]))))
(define _iname/upcase
(make-ctype
_string/utf-8
(λ (name)
(cond
[(or (not name) (string? name))
name]
[(keyword? name)
(string-upcase (regexp-replace* #rx"-" (keyword->string name) "_"))]
[(symbol? name)
(string-upcase (regexp-replace* #rx"-" (symbol->string name) "_"))]
[else
(error '_iname/upcase "bad name: ~e" name)]))
(λ (name)
(cond
[(or (not name) (regexp-match? #rx"[-a-z]" name))
name]
[else
(string->symbol (string-downcase (regexp-replace #rx"_" name "-")))]))))
(define _iname/downcase
(make-ctype
_string/utf-8
(λ (name)
(cond
[(or (not name) (string? name))
name]
[(keyword? name)
(string-downcase (regexp-replace* #rx"-" (keyword->string name) "_"))]
[(symbol? name)
(string-downcase (regexp-replace* #rx"-" (symbol->string name) "_"))]
[else
(error '_iname/downcase "bad name: ~e" name)]))
(λ (name)
(cond
[(or (not name) (regexp-match? #rx"[-A-Z]" name))
name]
[else
(string->symbol (string-downcase (regexp-replace #rx"_" name "-")))]))))
(provide
_ihandle _ihandle/null ihandle?
_istatus
_iname/upcase _iname/downcase)
(define libiup
(case (system-type 'os)
[(windows)
(ffi-lib "iup")]
[else
(ffi-lib "libiup")]))
(define libiup-im
(case (system-type 'os)
[(windows)
(ffi-lib "iupim")]
[else
(ffi-lib "libiupim")]))
(define libiup-imglib
(case (system-type 'os)
[(windows)
(ffi-lib "iupimglib")]
[else
(ffi-lib "libiupimglib")]))
(define iup-version
(get-ffi-obj
"IupVersion" libiup
(_fun -> _string/utf-8)))
(define load/led
(get-ffi-obj
"IupLoad" libiup
(_fun [file : _file] -> [status : _string]
-> (when status (error 'load/led "~a" status)))))
(define attribute-set!
(letrec ([set/string!
(get-ffi-obj
"IupStoreAttribute" libiup
(_fun [handle : _ihandle/null] [name : _iname/upcase] [value : _string/utf-8] -> _void))]
[set/handle!
(get-ffi-obj
"IupSetAttributeHandle" libiup
(_fun [handle : _ihandle/null] [name : _iname/upcase] [value : _ihandle] -> _void))])
(λ (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 (format "~s" value))]))))
(define attribute-reset!
(get-ffi-obj
"IupResetAttribute" libiup
(_fun [handle : _ihandle/null] [name : _iname/upcase] -> _void)))
(define attribute
(getter-with-setter
(get-ffi-obj
"IupGetAttribute" libiup
(_fun [handle : _ihandle/null] [name : _iname/upcase] -> [value : _string/utf-8]))
attribute-set!))
(define handle-name-set!
(get-ffi-obj
"IupSetHandle" libiup
(_fun (handle name)
:: [name : _iname/downcase = (or name (handle-name handle))]
[handle : _ihandle/null = (and name handle)]
-> [handle : _ihandle/null])))
(define handle-name
(getter-with-setter
(get-ffi-obj
"IupGetName" libiup
(_fun [handle : _ihandle] -> [name : _iname/downcase]))
handle-name-set!))
(define handle-ref
(get-ffi-obj
"IupGetHandle" libiup
(_fun [name : _iname/downcase] -> [handle : _ihandle/null])))
(define main-loop
(get-ffi-obj
"IupMainLoop" libiup
(_fun -> [status : _istatus]
-> (case status
[(#t) (void)]
[else (error 'main-loop "error in IUP main loop (~s)" status)]))))
(define main-loop-step
(letrec ([loop-step
(get-ffi-obj
"IupLoopStep" libiup
(_fun -> [status : _istatus]))]
[loop-step/wait
(get-ffi-obj
"IupLoopStepWait" libiup
(_fun -> [status : _istatus]))])
(λ (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
(get-ffi-obj
"IupMainLoopLevel" libiup
(_fun -> _int)))
(define main-loop-exit
(get-ffi-obj
"IupExitLoop" libiup
(_fun -> _void)))
(define main-loop-flush
(get-ffi-obj
"IupFlush" libiup
(_fun -> _void)))
(define callback-type
(letrec ([type-cache
(make-hash)]
[callback-signature
(get-ffi-obj
"iupClassCallbackGetFormat" libiup
(_fun [class : _pointer] [name : _iname/upcase] -> [format : _string/utf-8]))]
[char->type
(λ (location char param?)
(case char
[(#\b) _byte]
[(#\i) (if param? _int _istatus)]
[(#\f) _float]
[(#\d) _double]
[(#\s) _string/utf-8]
[(#\v) _pointer]
[(#\h) _ihandle/null]
[else (error location "bad callback ~s type ~e" (if param? "parameter" "return") char)]))])
(λ (location handle name)
(unless (ihandle? handle)
(raise-type-error location "non-null `ihandle' pointer" handle))
(let ([signature (callback-signature (ptr-ref (ptr-add handle 4) _pointer) name)])
(or
(hash-ref type-cache signature #f)
(match signature
[(regexp #rx"^([^=]*)(=.)?$" (list _ params return))
(let* ([return
(cond [return => (cut string-ref <> 1)] [else #\i])]
[type
(_cprocedure
(cons
_ihandle
(for/list ([char (in-string params)])
(char->type location char #t)))
(char->type location return #f)
#:keep #f)])
(hash-set! type-cache signature type)
type)]
[_
(error location "bad callback signature ~e" signature)]))))))
(define-values (registry-set! registry registry-destroy!)
(letrec ([registry-cell-set!
(get-ffi-obj
"IupSetAttribute" libiup
(_fun [handle : _ihandle] [name : _string/utf-8 = "RACKET_REGISTRY"] [cell : _pointer]
-> _void))]
[registry-cell
(get-ffi-obj
"IupGetAttribute" libiup
(_fun [handle : _ihandle] [name : _string/utf-8 = "RACKET_REGISTRY"]
-> [cell : _pointer]))])
(values
(λ (handle value)
(cond
[(registry-cell handle) => (cut ptr-set! <> _racket value)]
[else (registry-cell-set! handle (malloc-immobile-cell value))]))
(λ (handle)
(cond
[(registry-cell handle) => (cut ptr-ref <> _racket)]
[else null]))
(λ (handle)
(cond
[(registry-cell handle)
=> (λ (cell)
(registry-cell-set! handle #f)
(free-immobile-cell cell))])))))
(define callback-set!
(letrec ([set/pointer!
(get-ffi-obj
"IupSetCallback" libiup
(_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer]
-> [callback : _fpointer]))])
(λ (handle name callback)
(let ([callback (function-ptr callback (callback-type 'callback-set! handle name))])
(registry-set! handle
(cons
callback
(remove
(set/pointer! handle name callback)
(registry handle)
ptr-equal?)))))))
(define callback
(getter-with-setter
(get-ffi-obj
"IupGetCallback" libiup
(_fun [handle : _ihandle] [name : _iname/upcase]
-> [callback : _fpointer]
-> (cast callback _fpointer (callback-type 'callback handle name))))
callback-set!))
(define (make-constructor-procedure proc)
(make-keyword-procedure
(λ (keys key-args . pos-args)
(let ([handle (apply proc pos-args)])
(for ([key (in-list keys)] [arg (in-list key-args)])
((if (procedure? arg) callback-set! attribute-set!) handle key arg))
handle))))
(define create
(make-constructor-procedure
(get-ffi-obj
"IupCreate" libiup
(_fun [class : _iname/downcase] -> [handle : _ihandle/null]
-> (or handle (error 'create "failed to create instance of ~e" class))))))
(define destroy!
(letrec ([registry-destroy/recursive!
(λ (handle)
(registry-destroy! handle)
(for ([child (in-children handle)])
(registry-destroy/recursive! child)))]
[handle-destroy!
(get-ffi-obj
"IupDestroy" libiup
(_fun [handle : _ihandle] -> _void))])
(λ (handle)
(registry-destroy/recursive! handle)
(handle-destroy! handle))))
(define map-peer!
(get-ffi-obj
"IupMap" libiup
(_fun [handle : _ihandle] -> [status : _istatus]
-> (case status
[(#t) (void)]
[else (error 'map-peer! "failed to map the peer of ~e (~s)" handle status)]))))
(define unmap-peer!
(get-ffi-obj
"IupUnmap" libiup
(_fun [handle : _ihandle] -> _void)))
(define class-name
(get-ffi-obj
"IupGetClassName" libiup
(_fun [handle : _ihandle] -> [class : _iname/downcase])))
(define class-type
(get-ffi-obj
"IupGetClassType" libiup
(_fun [handle : _ihandle] -> [type : _iname/downcase])))
(define save-attributes!
(get-ffi-obj
"IupSaveClassAttributes" libiup
(_fun [handle : _ihandle] -> _void)))
(define parent
(get-ffi-obj
"IupGetParent" libiup
(_fun [child : _ihandle] -> [parent : _ihandle/null])))
(define parent-dialog
(get-ffi-obj
"IupGetDialog" libiup
(_fun [child : _ihandle] -> [dialog : _ihandle/null])))
(define sibling
(get-ffi-obj
"IupGetBrother" libiup
(_fun [child : _ihandle] -> [sibling : _ihandle/null])))
(define child-add!
(letrec ([append!
(get-ffi-obj
"IupAppend" libiup
(_fun [container : _ihandle] [child : _ihandle] -> [parent : _ihandle/null]))]
[insert!
(get-ffi-obj
"IupInsert" libiup
(_fun [container : _ihandle] [anchor : _ihandle] [child : _ihandle] -> [parent : _ihandle/null]))])
(λ (child container [anchor #f])
(or (if anchor
(insert! container anchor child)
(append! container child))
(if anchor
(error 'child-add! "failed to add ~e to ~e at ~e" child container anchor)
(error 'child-add! "failed to add ~e to ~e" child container))))))
(define child-remove!
(get-ffi-obj
"IupDetach" libiup
(_fun [child : _ihandle] -> _void)))
(define child-move!
(get-ffi-obj
"IupReparent" libiup
(_fun [child : _ihandle] [parent : _ihandle] -> [status : _istatus]
-> (case status
[(#t) (void)]
[else (error 'child-move! "failed to move ~e to ~e (~s)" child parent status)]))))
(define child-ref
(letrec ([ref/position
(get-ffi-obj
"IupGetChild" libiup
(_fun [parent : _ihandle] [position : _int] -> [child : _ihandle/null]))]
[ref/name
(get-ffi-obj
"IupGetDialogChild" libiup
(_fun [dialog : _ihandle] [name : _iname/upcase] -> [child : _ihandle/null]))])
(λ (container id)
((cond
[(integer? id) ref/position]
[else ref/name])
container id))))
(define child-pos
(get-ffi-obj
"IupGetChildPos" libiup
(_fun [parent : _ihandle] [child : _ihandle] -> [position : _int]
-> (and (not (negative? position)) position))))
(define child-count
(get-ffi-obj
"IupGetChildCount" libiup
(_fun [parent : _ihandle] -> [count : _int])))
(define in-children
(letrec ([next-child
(get-ffi-obj
"IupGetNextChild" libiup
(_fun [handle : _ihandle] [child : _ihandle/null] -> [child : _ihandle/null]))])
(λ (handle)
(make-do-sequence
(λ ()
(values
values
(cut next-child handle <>)
(next-child handle #f)
values
(const #t)
(const #t)))))))
(define (children handle)
(for/list ([child (in-children handle)])
child))
(define refresh
(get-ffi-obj
"IupRefresh" libiup
(_fun [handle : _ihandle] -> _void)))
(define redraw
(letrec ([update
(get-ffi-obj
"IupUpdate" libiup
(_fun [handle : _ihandle] -> _void))]
[update-children
(get-ffi-obj
"IupUpdateChildren" libiup
(_fun [handle : _ihandle] -> _void))]
[update/sync
(get-ffi-obj
"IupRedraw" libiup
(_fun [handle : _ihandle] [children? : _bool] -> _void))])
(λ (handle #:children? [children? #f] #:sync? [sync? #f])
(if sync?
(update/sync handle children?)
(begin
(update handle)
(when children? (update-children handle)))))))
(define child-x/y->pos
(get-ffi-obj
"IupConvertXYToPos" libiup
(_fun [parent : _ihandle] [x : _int] [y : _int] -> [position : _int]
-> (and (not (negative? position)) position))))
(define show
(letrec ([position
(λ (v)
(case v
[(center) #xffff]
[(start top left) #xfffe]
[(end bottom right) #xfffd]
[(mouse) #xfffc]
[(parent-center) #xfffa]
[(current) #xfffb]
[else v]))]
[popup
(get-ffi-obj
"IupPopup" libiup
(_fun [handle : _ihandle] [x : _int] [y : _int] -> [status : _istatus]))]
[show/x/y
(get-ffi-obj
"IupShowXY" libiup
(_fun [handle : _ihandle] [x : _int] [y : _int] -> [status : _istatus]))])
(λ (handle #:x [x 'current] #:y [y 'current] #:modal? [modal? #f])
(let ([status ((if modal? popup show/x/y) handle (position x) (position y))])
(case status
[(error) (error 'show "failed to show ~e" handle)]
[else status])))))
(define hide
(get-ffi-obj
"IupHide" libiup
(_fun [handle : _ihandle] -> [status : _istatus]
-> (case status
[(#t) (void)]
[else (error 'hide "failed to hide ~e (~s)" handle status)]))))
(define dialog
(make-constructor-procedure
(get-ffi-obj
"IupDialog" libiup
(_fun [child : _ihandle/null] -> [handle : _ihandle]))))
(define fill
(make-constructor-procedure
(get-ffi-obj
"IupFill" libiup
(_fun -> [handle : _ihandle]))))
(define hbox
(make-constructor-procedure
(get-ffi-obj
"IupHboxv" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define vbox
(make-constructor-procedure
(get-ffi-obj
"IupVboxv" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define zbox
(make-constructor-procedure
(get-ffi-obj
"IupZboxv" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define cbox
(make-constructor-procedure
(get-ffi-obj
"IupCboxv" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define sbox
(make-constructor-procedure
(get-ffi-obj
"IupSbox" libiup
(_fun [child : _ihandle/null] -> [handle : _ihandle]))))
(define radio
(make-constructor-procedure
(get-ffi-obj
"IupRadio" libiup
(_fun [child : _ihandle/null] -> [handle : _ihandle]))))
(define normalizer
(make-constructor-procedure
(get-ffi-obj
"IupNormalizerv" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define split
(make-constructor-procedure
(get-ffi-obj
"IupSplit" libiup
(_fun [child1 : _ihandle/null] [child2 : _ihandle/null] -> [handle : _ihandle]))))
(define image/palette
(make-constructor-procedure
(get-ffi-obj
"IupImage" libiup
(_fun [width : _int] [height : _int] [pixels : _bytes] -> [handle : _ihandle]))))
(define image/rgb
(make-constructor-procedure
(get-ffi-obj
"IupImageRGB" libiup
(_fun [width : _int] [height : _int] [pixels : _bytes] -> [handle : _ihandle]))))
(define image/rgba
(make-constructor-procedure
(get-ffi-obj
"IupImageRGBA" libiup
(_fun [width : _int] [height : _int] [pixels : _bytes] -> [handle : _ihandle]))))
(define image/file
(make-constructor-procedure
(get-ffi-obj
"IupLoadImage" libiup-im
(_fun [file : _file] -> [handle : _ihandle/null]
-> (or handle (error 'image/file "~a" (attribute #f 'iupim-lasterror)))))))
(define image-save
(get-ffi-obj
"IupSaveImage" libiup-im
(_fun [handle : _ihandle] [file : _file] [format : _iname/upcase] -> [ok? : _bool]
-> (unless ok? (error 'image-save "~a" (attribute #f 'iupim-lasterror))))))
(define current-focus
(letrec ([focus-get
(get-ffi-obj
"IupGetFocus" libiup
(_fun -> [handle : _ihandle]))]
[focus-set!
(get-ffi-obj
"IupSetFocus" libiup
(_fun [handle : _ihandle] -> [handle : _ihandle]))]
[current-focus
(case-lambda
[() (focus-get)]
[(handle) (focus-set! handle)])])
(getter-with-setter current-focus current-focus)))
(define focus-next
(get-ffi-obj
"IupNextField" libiup
(_fun ([handle (current-focus)]) :: [handle : _ihandle] -> [handle : _ihandle])))
(define focus-previous
(get-ffi-obj
"IupPreviousField" libiup
(_fun ([handle (current-focus)]) :: [handle : _ihandle] -> [handle : _ihandle])))
(define menu
(make-constructor-procedure
(get-ffi-obj
"IupMenu" libiup
(_fun children :: [children : (_list i _ihandle/null) = (append children '(#f))]
-> [handle : _ihandle]))))
(define menu-item
(letrec ([action-item
(get-ffi-obj
"IupItem" libiup
(_fun [title : _string/utf-8] [action : _iname/upcase] -> [handle : _ihandle]))]
[submenu-item
(get-ffi-obj
"IupSubmenu" libiup
(_fun [title : _string/utf-8] [menu : _ihandle] -> [handle : _ihandle]))])
(make-constructor-procedure
(λ ([title #f] [action/menu #f])
((if (ihandle? action/menu) submenu-item action-item) title action/menu)))))
(define menu-separator
(make-constructor-procedure
(get-ffi-obj
"IupSeparator" libiup
(_fun -> [handle : _ihandle]))))
(define clipboard
(make-constructor-procedure
(get-ffi-obj
"IupClipboard" libiup
(_fun -> [handle : _ihandle]))))
(define timer
(make-constructor-procedure
(get-ffi-obj
"IupTimer" libiup
(_fun -> [handle : _ihandle]))))
(define send-url
(get-ffi-obj
"IupHelp" libiup
(_fun [url : _string/utf-8] -> [status : _int]
-> (case status
[(1) (void)]
[else (error 'send-url "failed to open URL ~e (~s)" url status)]))))
(define thread-watchdog
(letrec ([open
(get-ffi-obj
"IupOpen" libiup
(_fun [argc : _pointer = #f] [argv : _pointer = #f]
-> [status : _istatus]
-> (case status
[(#t) #t]
[(ignore) #f]
[else (error 'iup "failed to initialize library (~s)" status)])))]
[setlocale
(get-ffi-obj
"setlocale" #f
(_fun [category : _int = 1] [locale : _string/utf-8 = "C"]
-> _void))]
[open-imglib
(get-ffi-obj
"IupImageLibOpen" libiup-imglib
(_fun -> _void))]
[close
(get-ffi-obj
"IupClose" libiup
(_fun -> _void))]
[callback-set!
(get-ffi-obj
"IupSetCallback" libiup
(_fun [handle : _ihandle] [name : _iname/upcase] [callback : _fpointer] -> _void))]
[scheme-check-threads
(get-ffi-obj
"scheme_check_threads" #f
_fpointer)])
(and-let* ([(dynamic-wind void open setlocale)]
[(open-imglib)]
[watchdog (timer)])
(register-finalizer
watchdog
(λ (watchdog)
(destroy! watchdog)
(close)))
(callback-set! watchdog 'action-cb scheme-check-threads)
(attribute-set! watchdog 'time 500)
(attribute-set! watchdog 'run #t)
watchdog)))
(provide
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
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
in-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)