#lang scheme
;; com-utils.ss
;; Utilities to work with the great COM framework...
(define trace-com #f)

(require (prefix-in mx: mysterx))

(require "../../utils.ss")

(provide get-property
         get-property*
         get-property-type
         get-property-type*
         set-property!
         set-property!*
         set-property-type
         set-property-type*

         method-type
         method-type*

         ;; Lists of methods and properties
         methods
         get-properties
         set-properties
         properties

         com-stats
         invoke
         invoke*

         get-com-object

         trace-com)


(define-syntax get-property
  (lambda (stx)
    (syntax-case stx ()
      [(_ obj prop)
       #`(mx:com-get-property obj #,(datum->syntax
                                     stx
                                     (symbol->string
                                      (syntax->datum #'prop))))])))
(define get-property* mx:com-get-property)

(define-syntax get-property-type
  (lambda (stx)
    (syntax-case stx ()
      [(_ obj prop)
       #`(mx:com-get-property-type obj #,(datum->syntax
                                          stx
                                          (symbol->string
                                           (syntax->datum #'prop))))])))
(define get-property-type* mx:com-get-property-type)

(define-syntax set-property!
  (lambda (stx)
    (syntax-case stx ()
      [(_ obj prop value)
       #`(mx:com-set-property! obj #,(datum->syntax
                                      stx
                                      (symbol->string
                                       (syntax->datum #'prop)))
                               value)])))
(define set-property!* mx:com-set-property!)

(define-syntax set-property-type
  (lambda (stx)
    (syntax-case stx ()
      [(_ obj prop value)
       #`(mx:com-set-property-type obj
                                   #,(datum->syntax
                                      stx
                                      (symbol->string
                                       (syntax->datum #'prop)))
                                   value)])))
(define set-property-type* mx:com-set-property-type)


(define-syntax method-type
  (lambda (stx)
    (syntax-case stx ()
      [(_ obj meth)
       #`(mx:com-method-type obj #,(datum->syntax
                                      stx
                                      (symbol->string
                                       (syntax->datum #'meth))))])))
(define method-type* mx:com-method-type)


(define (methods obj)
  (mx:com-methods obj))

(define (get-properties obj)
  (mx:com-get-properties obj))

(define (set-properties obj)
  (mx:com-set-properties obj))

(define (properties obj)
  (sort
   (remove-duplicates
    (append (get-properties obj)
            (set-properties obj)))))


;; invocation counter
(define invokes (make-hash))
(define (inc-invokes method)
  (let ((n (or (hash-ref invokes method #f)
               0)))
    (hash-set! invokes
               method
               (add1 n))))
(define (com-stats)
  (let ([c 0])
    (hash-for-each invokes
                   (lambda (key value)
                     (set! c (+ c value))))
    (display* invokes " (" c ") COM method invocations.")))

(define-syntax invoke
  (lambda (stx)
    (syntax-case stx ()
      [(_ meth obj arg ...)
       (let ([meth (datum->syntax stx
                                  (symbol->string
                                   (syntax->datum #'meth)))])
         #`(begin (inc-invokes #,meth)
                  (mx:com-invoke obj #,meth
                                 arg ...)))])))
(define (invoke* meth obj . args)
  (inc-invokes meth)
  (apply mx:com-invoke obj meth args))


(define (get-com-object coclass)
  (let ([create-object
         (lambda (exn)
           (with-handlers
               ((exn:fail?
                 (lambda (exn2)
                   (error
                    (string-append "Can't get an open `%s' object "
                                   "nor create an instance of it:\n%s")
                    coclass
                    (string-append (princ-to-string exn)
                                   "\n"
                                   (princ-to-string exn2))))))
             (display* "Couldn't create a `" coclass "' instance.\n"
                       "Trying to create a `" coclass "' object...")
             (flush-output)
             (mx:cci/coclass coclass)))])
    (with-handlers ((exn:fail? create-object))
      (mx:com-get-active-object-from-coclass coclass))))