;;; Copyright (c) 2013
;;; Michele La Monaca (mikele~lamonaca.net)
;;; All rights reserved.

#> #include <windows.h> <#

(define-foreign-variable MB_OK unsigned-long "MB_OK")
(define-foreign-variable MB_ABORTRETRYIGNORE unsigned-long "MB_ABORTRETRYIGNORE")
(define-foreign-variable MB_YESNOCANCEL unsigned-long "MB_YESNOCANCEL")
(define-foreign-variable MB_YESNO unsigned-long "MB_YESNO")
(define-foreign-variable MB_RETRYCANCEL unsigned-long "MB_RETRYCANCEL")
(define-foreign-variable MB_CANCELTRYCONTINUE unsigned-long "MB_CANCELTRYCONTINUE")

(define-foreign-variable MB_ICONSTOP unsigned-long "MB_ICONSTOP")
(define-foreign-variable MB_ICONQUESTION unsigned-long "MB_ICONQUESTION")
(define-foreign-variable MB_ICONEXCLAMATION unsigned-long "MB_ICONEXCLAMATION")
(define-foreign-variable MB_ICONINFORMATION unsigned-long "MB_ICONINFORMATION")

(define-foreign-variable MB_SETFOREGROUND unsigned-long "MB_SETFOREGROUND")
(define-foreign-variable MB_TOPMOST unsigned-long "MB_TOPMOST")

(define-foreign-variable IDOK unsigned-long "IDOK")
(define-foreign-variable IDCANCEL unsigned-long "IDCANCEL")
(define-foreign-variable IDABORT unsigned-long "IDABORT")
(define-foreign-variable IDRETRY unsigned-long "IDRETRY")
(define-foreign-variable IDIGNORE unsigned-long "IDIGNORE")
(define-foreign-variable IDYES unsigned-long "IDYES")
(define-foreign-variable IDNO unsigned-long "IDNO")
(define-foreign-variable IDTRYAGAIN unsigned-long "IDTRYAGAIN")
(define-foreign-variable IDCONTINUE unsigned-long "IDCONTINUE")

(define _msgbox
  (foreign-lambda* unsigned-short ((c-string msg) (c-string title) (unsigned-long flags))
     "C_return(MessageBox(NULL, TEXT(msg), TEXT(title), flags));"
))

(define (msgbox msg #!key (title "")
                          (buttons 'ok)
                          (default-button 1)
                          (icon 'none)
                          (foreground #t)
                          (topmost #f))
  (cond ((eq? buttons 'ok/cancel)
         (set! buttons MB_OK))
        ((eq? buttons 'abort/retry/ignore)
         (set! buttons MB_ABORTRETRYIGNORE))
        ((eq? buttons 'yes/no/cancel)
         (set! buttons MB_YESNOCANCEL))
        ((eq? buttons 'yes/no)
         (set! buttons MB_YESNO))
        ((eq? buttons 'retry/cancel)
         (set! buttons MB_RETRYCANCEL))
        ((eq? buttons 'cancel/try/continue)
         (set! buttons MB_CANCELTRYCONTINUE))
        (else (set! buttons MB_OK)))
  (cond ((eq? icon 'stop)
         (set! icon MB_ICONSTOP))
        ((eq? icon 'question)
         (set! icon MB_ICONQUESTION))
        ((eq? icon 'exclamation)
         (set! icon MB_ICONEXCLAMATION))
        ((eq? icon 'information)
         (set! icon MB_ICONINFORMATION))
        (else (set! icon 0)))
  (case default-button
    ((1 2 3 4) (set! default-button (* (- default-button 1) 256)))
    (else (set! default-button 0)))
  (let ((ui (_msgbox msg title (+ buttons default-button icon
                                (if foreground MB_SETFOREGROUND 0)
                                (if topmost MB_TOPMOST 0)))))
    (cond ((eq? ui IDOK) 'ok)
          ((eq? ui IDCANCEL) 'cancel)
          ((eq? ui IDABORT) 'abort)
          ((eq? ui IDRETRY) 'retry)
          ((eq? ui IDIGNORE) 'ignore)
          ((eq? ui IDYES) 'yes)
          ((eq? ui IDNO) 'no)
          ((eq? ui IDTRYAGAIN) 'tryagain)
          ((eq? ui IDCONTINUE) 'continue))))