#lang racket
(require
 srfi/2
 srfi/17
 srfi/26
 ffi/unsafe)

;; Data types

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

;; System functions

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

;; Attribute functions

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

;; Event functions

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

;; Layout functions

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

;; Dialog functions

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

;; Composition functions

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

;; Image resource functions

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

;; Focus functions

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

;; Menu functions

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

;; Miscellaneous resource functions

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

;; The library watchdog

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