;; -*- mode: Scheme; tab-width: 2; -*- ;;
;; {{{ 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")
(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 ((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
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-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 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));")]
[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)))
;; }}}