#lang racket/base
(require racket/class
         racket/draw
         (only-in racket/list take drop)
         ffi/unsafe
          "../../syntax.rkt"
          "../../lock.rkt"
          "../common/event.rkt"
         "item.rkt"
	 "utils.rkt"
	 "const.rkt"
	 "window.rkt"
	 "wndclass.rkt"
         "types.rkt")

(provide
 (protect-out list-box%))

(define WS_EX_CLIENTEDGE        #x00000200)

(define LBS_NOTIFY            #x0001)
(define LBS_MULTIPLESEL       #x0008)
(define LBS_HASSTRINGS        #x0040)
(define LBS_MULTICOLUMN       #x0200)
(define LBS_WANTKEYBOARDINPUT #x0400)
(define LBS_EXTENDEDSEL       #x0800)
(define LBS_DISABLENOSCROLL   #x1000)

(define LBN_SELCHANGE       1)
(define LBN_DBLCLK          2)

(define LB_ERR -1)

(define LB_ADDSTRING          #x0180)
(define LB_RESETCONTENT       #x0184)
(define LB_INSERTSTRING       #x0181)
(define LB_DELETESTRING       #x0182)
(define LB_GETTOPINDEX        #x018E)
(define LB_SETTOPINDEX        #x0197)
(define LB_GETITEMHEIGHT      #x01A1)
(define LB_GETSELCOUNT        #x0190)
(define LB_GETSELITEMS        #x0191)
(define LB_GETCURSEL          #x0188)
(define LB_SETSEL             #x0185)
(define LB_SETCURSEL          #x0186)
(define LB_GETSEL             #x0187)
(define LB_SELITEMRANGE       #x019B)

(define LVCF_WIDTH              #x0002)
(define LVCF_TEXT               #x0004)
(define LVCF_MINWIDTH           #x0040)

(define LVS_REPORT              #x0001)
(define LVS_SINGLESEL           #x0004)
(define LVS_NOCOLUMNHEADER      #x4000)
(define LVS_SHOWSELALWAYS       #x0008)

(define LVS_EX_HEADERDRAGDROP   #x00000010)
(define LVS_EX_FULLROWSELECT    #x00000020)

(define LVIF_TEXT               #x0001)
(define LVIF_DI_SETITEM         #x1000)

(define LVM_FIRST               #x1000)
(define LVM_INSERTITEMW         (+ LVM_FIRST 77))
(define LVM_GETSTRINGWIDTHW     (+ LVM_FIRST 87))
(define LVM_INSERTCOLUMNW       (+ LVM_FIRST 97))
(define LVM_DELETECOLUMN        (+ LVM_FIRST 28))
(define LVM_SETCOLUMNW          (+ LVM_FIRST 96))
(define LVM_GETCOLUMNW          (+ LVM_FIRST 95))
(define LVM_SETITEMTEXTW        (+ LVM_FIRST 116))
(define LVM_DELETEALLITEMS      (+ LVM_FIRST 9))
(define LVM_GETTOPINDEX         (+ LVM_FIRST 39))
(define LVM_GETCOUNTPERPAGE     (+ LVM_FIRST 40))
(define LVM_ENSUREVISIBLE       (+ LVM_FIRST 19))
(define LVM_DELETEITEM          (+ LVM_FIRST 8))
(define LVM_GETSELECTEDCOUNT    (+ LVM_FIRST 50))
(define LVM_GETNEXTITEM         (+ LVM_FIRST 12))
(define LVM_GETITEMSTATE        (+ LVM_FIRST 44))
(define LVM_SETITEMSTATE        (+ LVM_FIRST 43))
(define LVM_SETEXTENDEDLISTVIEWSTYLE (+ LVM_FIRST 54))
(define LVM_SETCOLUMNORDERARRAY (+ LVM_FIRST 58))
(define LVM_GETCOLUMNORDERARRAY (+ LVM_FIRST 59))

(define LVN_FIRST               -100)
(define LVN_ITEMCHANGED         (- LVN_FIRST 1))
(define LVN_COLUMNCLICK         (- LVN_FIRST 8))

(define NM_FIRST                0)
(define NM_DBLCLK               (- NM_FIRST 3))

(define LVNI_SELECTED           #x0002)
(define LVIS_SELECTED           #x0002)

(define-cstruct _LVCOLUMN
  ([mask _UINT]
   [fmt _int]
   [cx _int]
   [pszText _permanent-string/utf-16]
   [cchTextMax _int]
   [iSubItem _int]
   [iImage _int]
   [iOrder _int]
   [cxMin _int]
   [cxDefault _int]
   [cxIdeal _int]))

(define (make-lvcolumn flags label)
  (make-LVCOLUMN flags
                 0 0 
                 label
                 0 0 0 0 0 0 0))

(define (free-lvcolumn lv)
  (let ([s (LVCOLUMN-pszText lv)])
    (when s (free s))))

(define column-desc (cast (malloc (ctype-sizeof _LVCOLUMN) 'raw)
                          _pointer 
                          _LVCOLUMN-pointer))
(memset column-desc 0 (ctype-sizeof _LVCOLUMN))

;; Microsoft docs say to add padding to a ListView
;; item's width, but it doesn't say how much padding:
(define COLUMN-PADDING 16)

(define-cstruct _LVITEM
  ([mask _UINT]
   [iItem _int]
   [iSubItem _int]
   [state _UINT]
   [stateMask _UINT]
   [pszText _permanent-string/utf-16]
   [cchTextMax _int]
   [iImage _int]
   [lParam _LPARAM]
   [iIndent _int]
   [iGroupId _int]
   [cColumns _UINT]
   [puColumns _UINT]
   [piColFmt _int]
   [iGroup _int]))

(define (make-lvitem flags pos col label)
  (make-LVITEM flags
               pos col
               0 0 ; state & statemask
               label
               0 0 
               0 ; lParam
               0 0 0
               0 0 0))

(define (free-lvitem lv)
  (let ([s (LVITEM-pszText lv)])
    (when s (free s))))

(define-cstruct _NMLISTVIEW
  ([hdr _NMHDR]
   [iItem _int]
   [iSubItem _int]
   ;; ....
   ))

(define suppress-callback (make-parameter #f))

;; ------------------------------------------------------------

(define list-box%
  (class item%
    (init parent cb
          label kind x y w h
          choices style
          font label-font
          columns column-order)

    (inherit set-size set-control-font
             get-client-size)

    (define num-columns (length columns))
    (define single-column? (and (= 1 num-columns)
                                (not (memq 'column-headers style))
                                (not (memq 'variable-columns style))))
    (define single? (eq? 'single kind))

    (define hwnd
      (CreateWindowExW/control WS_EX_CLIENTEDGE
                               (if single-column?
                                   "PLTLISTBOX"
                                   "PLTSysListView32")
                               label
                               (if single-column?
                                   (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
                                                WS_VSCROLL
                                                (if (memq 'hscroll style) WS_HSCROLL 0)
                                                (cond
                                                 ;; Win32 sense of "multiple" and "extended" is backwards
                                                 [(eq? kind 'extended) LBS_MULTIPLESEL]
                                                 [(eq? kind 'multiple) LBS_EXTENDEDSEL]
                                                 [else 0]))
                                   (bitwise-ior WS_CHILD WS_CLIPSIBLINGS
                                                LVS_REPORT 
                                                (if (memq 'column-headers style)
                                                    0
                                                    LVS_NOCOLUMNHEADER)
                                                LVS_SHOWSELALWAYS
                                                WS_VSCROLL
                                                (if (memq 'hscroll style) WS_HSCROLL 0)
                                                (cond
                                                 [(eq? kind 'extended) 0]
                                                 [(eq? kind 'multiple) 0]
                                                 [else LVS_SINGLESEL])))
                               0 0 0 0
                               (send parent get-content-hwnd)
                               #f
                               hInstance
                               #f))

    (when single-column?
      (for ([s (in-list choices)])
        (SendMessageW/str hwnd LB_ADDSTRING 0 s)))
    
    (unless single-column?
      (for ([label (in-list columns)]
            [col (in-naturals)])
        (atomically
         (let ([col-desc (make-lvcolumn LVCF_TEXT label)])
           (SendMessageW/ptr hwnd LVM_INSERTCOLUMNW col col-desc)
           (free-lvcolumn col-desc)))
        (let* ([label-width
                (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label)]
               [max-width
                (if (zero? col)
                    ;; size column based on the content:
                    (for/fold ([w label-width]) ([s (in-list choices)]
                                                 [i (in-naturals)])
                      (atomically
                       (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
                                                           LVIF_TEXT)
                                              i
                                              col
                                              s)])
                         (if (zero? col)
                             (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
                             (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
                         (free-lvitem lv)))
                      (max w 
                           (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 s)))
                    ;; size column based on the label, only:
                    label-width)])
          (let ([col-desc (make-lvcolumn LVCF_WIDTH #f)])
            (set-LVCOLUMN-cx! col-desc (+ max-width COLUMN-PADDING))
            (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)))))

    (unless single-column?
      (SendMessageW hwnd LVM_SETEXTENDEDLISTVIEWSTYLE 0 
                    (bitwise-ior LVS_EX_FULLROWSELECT
                                 (if (memq 'reorderable-headers style)
                                     LVS_EX_HEADERDRAGDROP
                                     0))))

    (when column-order
      (set-column-order column-order))

    (super-new [callback cb]
               [parent parent]
               [hwnd hwnd]
               [style style])

    (set-control-font font)
    (set-size #f #f 40 60)

    (define/override (size->screen v) (->screen* v))

    (define callback cb)

    (define/override (is-command? cmd)
      (if single-column?
          (or (= cmd LBN_SELCHANGE)
              (= cmd LBN_DBLCLK))
          (or (= cmd LVN_ITEMCHANGED)
              (= cmd NM_DBLCLK)
              (= cmd LVN_COLUMNCLICK))))
    
    (define pending-changed (box #f))
    (define/override (do-command cmd control-hwnd)
      (unless (suppress-callback)
        ;; LVN_ITEMCHANGED notifications, in particular, get
        ;; set for each item that changes in a selection change.
        ;; Use a box to cancel pending callbacks to collapse the
        ;; multiple callbacks into one.
        (set-box! pending-changed #f)
        (let ([b (box #t)]
              [t (if (if single-column?
                         (= cmd LBN_SELCHANGE)
                         (= cmd LVN_ITEMCHANGED))
                     'list-box
                     'list-box-dclick)])
          (unless (eq? t 'list-box-dclick)
            (set! pending-changed b))
          (queue-window-event 
           this 
           (lambda ()
             (when (unbox b)
               (callback this
                         (new control-event%
                              [event-type t]
                              [time-stamp (current-milliseconds)]))))))))
    
    (define/override (do-command-ex cmd control-hwnd nmhdr)
      (if (and (not single-column?)
               (= cmd LVN_COLUMNCLICK))
          (let ([col (NMLISTVIEW-iSubItem
                      (cast nmhdr _pointer _NMLISTVIEW-pointer))])
            (queue-window-event this (lambda ()
                                       (callback this
                                                 (new column-control-event%
                                                      [column col]
                                                      [event-type 'list-box-column]
                                                      [time-stamp (current-milliseconds)])))))
          (super do-command-ex cmd control-hwnd nmhdr)))
    
    (define num (length choices))
    (define/public (number) num)

    (define data (map (lambda (x) (box #f)) choices))
    (define/public (get-data i) (unbox (list-ref data i)))
    (define/public (set-data i v) (set-box! (list-ref data i) v))

    (define/public (set-string i str [col 0])
      (atomically
       (if single-column?
           (begin
             (SendMessageW/str hwnd LB_INSERTSTRING i str)
             (SendMessageW hwnd LB_DELETESTRING (add1 i) 0))
           (let ([lv (make-lvitem 0
                                  0
                                  col
                                  str)])
             (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv)
             (free-lvitem lv)))
       (void)))


    (define/public (set-column-order column-order)
      (unless single-column?
        (let* ([count num-columns]
               [a (malloc _int count)])
          (for ([n (in-list column-order)]
                [i (in-range count)])
            (ptr-set! a _int i n))
          (SendMessageW/ptr hwnd LVM_SETCOLUMNORDERARRAY count a)
          (InvalidateRect hwnd #f #f))))

    (define/public (get-column-order)
      (if single-column?
          '(0)
          (let* ([count num-columns]
                 [a (malloc _int count)])
            (SendMessageW/ptr hwnd LVM_GETCOLUMNORDERARRAY count a)
            (cast a _gcpointer (_list o _int count)))))

    (define/public (set-column-label col s)
      (unless single-column?
        (atomically
         (let ([col-desc (make-lvcolumn LVCF_TEXT s)])
           (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
           (free-lvcolumn col-desc)))))

    (define min-col-width 0) ; not kept for us by XP
    (define max-col-width 10000)
    (define/public (set-column-size col w mn mx)
      (if single-column?
          (atomically
           (set! min-col-width mn)
           (set! max-col-width mx))
          (atomically
           (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
             (set-LVCOLUMN-cx! col-desc (->screen w))
             (set-LVCOLUMN-cxMin! col-desc (->screen mn))
             (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
             (set! min-col-width mn)
             (set! max-col-width mx)))))

    (define/public (get-column-size col)
      (atomically
       (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
         (SendMessageW/ptr hwnd LVM_GETCOLUMNW col col-desc)
         (let ([v (->normal (LVCOLUMN-cx col-desc))])
           (values (max v min-col-width) ; in XP, may have been sized too small
                   min-col-width
                   max-col-width)))))

    (define/public (append-column label)
      (atomically
       (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_TEXT
                                                   LVCF_WIDTH)
                                      label)])
         (set-LVCOLUMN-cx! col-desc 
                           (SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label))
         (SendMessageW/ptr hwnd LVM_INSERTCOLUMNW num-columns col-desc)
         (free-lvcolumn col-desc))
       (set! num-columns (add1 num-columns))))

    (define/public (delete-column col)
      (atomically
       (SendMessageW hwnd LVM_DELETECOLUMN col 0)
       (set! num-columns (sub1 num-columns))))

    (define/public (set-first-visible-item i)
      (if single-column?
          (void (SendMessageW hwnd LB_SETTOPINDEX i 0))
          (let ([c (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)])
            (if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0)
                   i)
                (void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0))
                (void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0))))))

    (define/public (get-first-item)
      (SendMessageW hwnd (if single-column? LB_GETTOPINDEX LVM_GETTOPINDEX) 0 0))

    (define/public (number-of-visible-items)
      (if single-column?
          (let ([ih (->normal (SendMessageW hwnd LB_GETITEMHEIGHT 0 0))])
            (let ([w (box 0)]
                  [h (box 0)])
              (get-client-size w h)
              (quotient (unbox h) ih)))
          (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)))

    (define/public (clear)
      (atomically
       (set! data null)
       (set! num 0)
       (void (SendMessageW hwnd (if single-column? 
                                    LB_RESETCONTENT 
                                    LVM_DELETEALLITEMS)
                           0 0))))

    (define/public (set choices . more-choices)
      (atomically
       (ShowWindow hwnd SW_HIDE)
       (clear)
       (if single-column?
           (for ([s (in-list choices)])
             (SendMessageW/str hwnd LB_ADDSTRING 0 s))
           (for ([choices (in-list (cons choices more-choices))]
                 [col (in-naturals)])
             (for ([s (in-list choices)]
                   [i (in-naturals)])
             (atomically
              (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
                                                           LVIF_TEXT)
                                     i
                                     col
                                     s)])
                (if (zero? col)
                    (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
                    (SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
                (free-lvitem lv))))))
       (set! data (map (lambda (s) (box #f)) choices))
       (set! num (length choices))
       (ShowWindow hwnd SW_SHOW)))

    (public [append* append])
    (define (append* s [v #f])
      (atomically
       (if single-column?
           (SendMessageW/str hwnd LB_ADDSTRING 0 s)
           (let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
                                               LVIF_TEXT)
                                  num
                                  0
                                  s)])
             (SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
             (free-lvitem lv)))
       (set! num (add1 num))
       (set! data (append data (list (box v))))))

    (define/public (delete i)
      (atomically
       (set! data (append (take data i) (drop data (add1 i))))
       (set! num (sub1 num))
       (void (SendMessageW hwnd (if single-column?
                                    LB_DELETESTRING
                                    LVM_DELETEITEM)
                           i 0))))

    (define/public (get-selections)
      (atomically
       (if single-column?
           (if single?
               (let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)])
                 (if (= v LB_ERR)
                     null
                     (list v)))
               (let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)])
                 (if (zero? n)
                     null
                     (let ([selections (malloc n _LONG 'raw)])
                       (SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM))
                       (begin0
                        (for/list ([i (in-range n)])
                          (ptr-ref selections _LONG i))
                        (free selections))))))
           (let loop ([c (SendMessageW hwnd LVM_GETSELECTEDCOUNT 0 0)]
                      [pos -1])
             (cond
              [(zero? c) null]
              [else (let ([pos (SendMessageW hwnd LVM_GETNEXTITEM pos LVNI_SELECTED)])
                      (cons pos (loop (sub1 c) pos)))])))))

    (define/public (get-selection)
      (let ([l (get-selections)])
        (if (null? l)
            -1
            (car l))))

    (define/public (selected? i)
      (if single-column?
          (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))
          (not (zero? (SendMessageW hwnd LVM_GETITEMSTATE i LVIS_SELECTED)))))

    (define/public (select i [on? #t] [one? #t])
      (parameterize ([suppress-callback #t])
        (void
         (if single-column?
             (if single?
                 (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
                 (begin
                   (unless one?
                     (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
                   (SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))
             (let ([lv (make-lvitem 0 0 0 #f)])
               (define (set-one i on?)
                 (set-LVITEM-stateMask! lv LVIS_SELECTED)
                 (set-LVITEM-state! lv (if on? LVIS_SELECTED 0))
                 (SendMessageW/ptr hwnd LVM_SETITEMSTATE i lv))
               (when (and on? (not single?) (not one?))
                 (for ([i (in-list (get-selections))])
                   (set-one i #f)))
               (set-one i on?))))))

    (define/public (set-selection i)
      (void (select i #t #f)))

    (def/public-unimplemented get-label-font)))
