#lang racket/base

(require racket/match
         ffi/unsafe
         ffi/unsafe/define
         (for-syntax racket/base
                     racket/syntax))

(define textcs-lib (ffi-lib "text_cs.dll"))

(define-ffi-definer define-textcs textcs-lib)

(define _DWORD _uint32)

(define (_string/locale/len n)
  (make-ctype (make-array-type _byte n)
              ;; ->C
              (lambda (in)
                (cond
                 [(not in)
                  (make-bytes n)]
                 [(string? in)
                  (define bs (string->bytes/locale in))
                  (cond
                   [((bytes-length bs) . >= . n) ;; len+1 > n
                    (error '_string/locale/len "string is too long\n~v" in)]
                   [else
                    #;(define out (make-bytes n))
                    #;(bytes-copy! out 0 bs)
                    #;out
                    bs])]
                 [else
                  (error '_string/locale/len "expected string? or #f, got ~v" in)]))
              ;; ->racket
              (lambda (in)
                (define bs (make-sized-byte-string in n))
                (define Len
                  (for/fold ([acc 0])
                            ([by (in-bytes bs)]
                             [pos (in-naturals)]
                             #:final (zero? by))
                    pos))
                (bytes->string/locale (subbytes bs 0 Len)))))

(define-cstruct _CMN_ERROR
  ([dwError1   _uint32]
   [dwError2   _uint32]
   [dwError3   _uint32]
   [dwError4   _uint32]
   [dwError5   _uint32]
   [szErrorText (_string/locale/len 512)])
  #:alignment 1)

(define (make-cmn-error)
  (make-CMN_ERROR 0 0 0 0 0 ""))

(define (cmn-error->string cmn-error)
  (match-define (CMN_ERROR dwError1 dwError2 dwError3 dwError4 dwError5 szErrorText) cmn-error)
  (string-append
   "\n"
   (format "  dwError1: 0x~a\n" (number->string dwError1 16))
   (format "  dwError2: 0x~a\n" (number->string dwError2 16))
   (format "  dwError3: 0x~a\n" (number->string dwError3 16))
   (format "  dwError4: 0x~a\n" (number->string dwError4 16))
   (format "  dwError5: 0x~a\n" (number->string dwError5 16))
   (format "  szErrorText: ~a\n" szErrorText)))

(define _TXT_ENUM_INFOTEXTS_PROC
  (_cprocedure (list _DWORD _string/locale _pointer)
               _bool
               #:abi 'sysv))

(define TXTEnumInfoText
  (_fun #:atomic? #t
        (lpszProjectFile   : _string/locale)
        (dwLocale          : _DWORD)
        (lpdwItems         : _pointer)
        (lpszFilter        : _string/locale)
        (lpfnEnum          : _TXT_ENUM_INFOTEXTS_PROC)
        (lpvUser           : _pointer)
        (lpError           : _CMN_ERROR-pointer)
        -> _bool))

(define current-project (make-parameter (lambda _ (error "not initialized"))))

(define (enum-texts #:locale [locale-id 1049]
                    #:filter [filter ""]
                    #:project [project (current-project)])
  (define result (make-hash))
  (define (callback dwTextID lpszInfoText lpvUser)
    (hash-update! result
                  lpszInfoText
                  (lambda (id-lst)
                    (append id-lst (list dwTextID)))
                  '())
    #t)
  (define lpdwItems (make-bytes (ctype-sizeof _DWORD) 0))
  (define cmn-error (make-cmn-error))
  (define r (TXTEnumInfoText project
                             locale-id
                             lpdwItems
                             filter
                             callback
                             #f
                             cmn-error
                             ))
  (unless r
    (error 'enum-texts (cmn-error->string cmn-error)))
  result)