#lang racket/base
(require racket/class
         racket/draw
         racket/promise
         ffi/unsafe
          "../../syntax.rkt"
          "../common/event.rkt"
         "item.rkt"
	 "utils.rkt"
	 "const.rkt"
	 "window.rkt"
	 "wndclass.rkt"
         "hbitmap.rkt"
         "types.rkt"
	 "icons.rkt")

(provide
 (protect-out message%))

(define STM_SETIMAGE        #x0172)

(define SS_LEFT #x00000000)
(define SS_LEFTNOWORDWRAP #x0000000C)
(define SS_BITMAP #x0000000E)
(define SS_ICON #x00000003)

(define IMAGE_ICON 1)

(define warning-icon
  (delay
    (LoadIconW #f IDI_WARNING)))
(define error-icon
  (delay
    (LoadIconW #f IDI_ERROR)))

(define message%
  (class item%
    (inherit auto-size set-size set-control-font get-hwnd
             remember-label-bitmap)

    (init parent label
          x y
          style font)
    (init-field color)

    (define bitmap? (label . is-a? . bitmap%))
    (define text-label? (string? label))

    (define/public (get-class) "PLTSTATIC")
    
    (super-new [callback void]
               [parent parent]
               [hwnd 
                (CreateWindowExW/control 0
                                         (get-class)
                                         (if (string? label)
                                             label
                                             "<image>")
                                         (bitwise-ior (if (string? label)
							  SS_LEFTNOWORDWRAP
							  SS_LEFT)
						      WS_CHILD WS_CLIPSIBLINGS
                                                      (if bitmap?
                                                          SS_BITMAP
                                                          (if (symbol? label)
                                                              SS_ICON
                                                              0)))
                                         0 0 0 0
                                         (send parent get-content-hwnd)
                                         #f
                                         hInstance
                                         #f)]
               [style style])

    (when bitmap?
      (let ([hbitmap (bitmap->hbitmap label)])
        (remember-label-bitmap hbitmap)
        (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP 
                      (cast hbitmap _HBITMAP _LPARAM))))

    (when (symbol? label)
      (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_ICON
                    (cast (case label
			    [(caution) (force warning-icon)]
			    [(stop) (force error-icon)]
			    [else app-icon])
                          _HICON _LPARAM)))
    
    (set-control-font font)

    (if (symbol? label)
        (set-size #f #f 32 32)
        (auto-size font (strip-& label) 0 0 0 0))

    (define/public (set-preferred-size) #f)

    (define/override (get-setimage-message)
      STM_SETIMAGE)

    (define/override (control-will-color hdc)
      (cond
        [(and text-label? color)
         (define bg-color (GetPixel hdc 0 0))
         (define fg-color
           (COLORREF-alpha-blend
            (make-COLORREF
             (send color red)
             (send color green)
             (send color blue))
            bg-color
            (send color alpha)))
         (SetBkColor hdc bg-color)
         (SetTextColor hdc fg-color)
         (cast (GetSysColorBrush COLOR_WINDOW) _HBRUSH _LRESULT)]
        [else #f]))

    (define/override (set-label label)
      (set! text-label? (string? label))
      (super set-label label))

    (define/public (get-color) color)
    (define/public (set-color c)
      (when text-label?
        (set! color c)
        (InvalidateRect (get-hwnd) #f #f)))))
