;;; objc Scheme<->ObjC bridge

;(objc:import-classes-at-toplevel!)

(module objc
  (
   ;; Internal API.  Some is required to be visible for the macros
   ;; but much of it does not need to be exported.
   add-method-definition
   alignof-type
   allocate-ivar-list
   arg-converter
   c-c-string0
   char->ref
   class-of
   create-invocation
   double->ref
   find-ivar
   find-superclass-method
   float->ref
   get-return-value!
   instance-selector-to-signature
   int->ref
   invoke
   invoke-safe
   is-nsstring
   ivar-base-offset
   long->ref
   make-autorelease-pool
   make-imp-closure
   make-method-proxy
   ;; make-ns:point
   ;; make-ns:range
   ;; make-ns:rect
   ;; make-ns:size
   make-nsstring
   make-objc-ffi-closure
   make-objc:class
   make-objc:instance
   make-objc:raw-ivar
   method-argument-count
   method-argument-type
   method-return-length
   method-return-type
   new-autorelease-pool
   nsstring-to-string
   objc-description
   objc-release
   objc-retain
   objc-retain-count
   objc:BOOL
   objc:CHARPTR
   objc:CHR
   objc:CLASS
   objc:DBL
   objc:FLT
   objc:ID
   objc:INT
   objc:LNG
   objc:NSPOINT
   objc:NSRANGE
   objc:NSRECT
   objc:NSSIZE
   objc:PTR
   objc:SEL
   objc:SHT
   objc:UCHR
   objc:UINT
   objc:ULNG
   objc:USHT
   objc:VOID
   objc:_get_class_list!
   objc:alignof-type
   objc:char->char-or-bool
   objc:char-or-bool->char
   objc:char-or-bool->ref
   objc:class->ref
   objc:class-objc?
   objc:class-or-instance-ptr
   objc:class-ptr
   objc:class-ptr-set!
   objc:classes
   objc:instance->pointer
   objc:instance->ref
   objc:instance-ptr
   objc:instance-ptr-set!
   objc:invoker
   objc:number-of-classes
   objc:ref->char-or-bool
   objc:ref->class
   objc:ref->instance
   objc:ref->scheme-object
   objc:ref->selector
   objc:scheme-object->ref
   objc:selector->ref
   objc:sizeof-type
   objc_class_method_list
   pointer-ptr-ref
   ptr->ref
   ptr-array->pointer-vector!
   ptr-array-map->list
   ptr-array-ref
   ref->char
   ref->double
   ref->float
   ref->int
   ref->long
   ref->ns:point
   ref->ns:range
   ref->ns:rect
   ref->ns:size
   ref->ptr
   ref->short
   ref->string
   ref->struct
   ref->uchar
   ref->uint
   ref->ulong
   ref->ushort
   ref->void
   ref_to_scheme_object
   register-class
   result-converter
   retain-and-autorelease
   retain-count
   scheme_object_to_ref
   selector-allocates?
   selector-to-signature
   set-class-ivar
   set-method-argument
   short->ref
   signature-to-ffi-return-type
   signature-to-ffi-type
   sizeof-result-type
   sizeof-type
   string->new-selector
   string->ref
   string->selector
   string-to-class
   struct->ref
   struct-to-ffi-type
   uchar->ref
   uint->ref
   ulong->ref
   ushort->ref
   vector-map->list
   void->ref

;;; public API

   @
   define-objc-class
   define-objc-classes
   ivar-ref
   ivar-set!

   ;; ns: records
   ns:make-point
   ns:make-range
   ns:make-rect
   ns:make-size
   ns:point->ref
   ns:point-x
   ns:point-x-set!
   ns:point-y
   ns:point-y-set!
   ns:point?
   ns:range->ref
   ns:range-length
   ns:range-length-set!
   ns:range-location
   ns:range-location-set!
   ns:range?
   ns:rect->ref
   ns:rect-height
   ns:rect-height-set!
   ns:rect-width
   ns:rect-width-set!
   ns:rect-x
   ns:rect-x-set!
   ns:rect-y
   ns:rect-y-set!
   ns:rect?
   ns:size->ref
   ns:size-height
   ns:size-height-set!
   ns:size-width
   ns:size-width-set!
   ns:size?
   
   objc:add-class-method
   objc:add-method
   objc:allow-class-redefinition
   objc:class->pointer
   ;; objc:class record
   objc:class-class-method-list
   objc:class-ivar-list
   objc:class-ivars
   objc:class-meta-class
   objc:class-method-list
   objc:class-name
   objc:class-super-class
   objc:class?

   objc:class-of
   objc:define-class-method
   objc:define-method   
   objc:get-class-list
   objc:import-classes-at-toplevel!
   objc:instance?
   objc:ivar-ref
   objc:ivar-set!
   objc:nsstring
   objc:nsstring->string
   objc:optimize-callbacks
   objc:pointer->class
   objc:pointer->instance
   ;; objc:raw-ivar record
   objc:raw-ivar-name
   objc:raw-ivar-name-set!
   objc:raw-ivar-offset
   objc:raw-ivar-offset-set!
   objc:raw-ivar-type
   objc:raw-ivar-type-set!
   objc:raw-ivar?

   objc:register-class
   objc:send
   objc:send/safe
   objc:send/maybe-safe
   objc:set-ivars!
   objc:string->class
   with-autorelease-pool

   ;; for define-objc-class:
   objc:class-objc?-set!
   make-objc:ivar
   objc:ivar->raw
   objc:class-ivars-set!
   objc:ivar-name
   objc:add-convenience-method!
   objc_method_dealloc   ;?
   )

(import scheme chicken)
(require-extension extras lolevel data-structures foreigners easyffi srfi-13 srfi-69)
(import foreign)
(include "objc-support.scm")

;;; invoker macros

;; (objc TypeTest printInt: 1.1 Double: 2.2 Float: 3.3)
;; Allows target "super" -- e.g. @[super init] is transformed
;; into @[self classname:super:init].  (The classname: is required
;; because super calls the superclass of the class defining method, not
;; the superclass of self.)

(define-syntax objc:send
  (lambda (e r c) (%objc r #f (cadr e) (caddr e) (cdddr e))))
(define-syntax objc:send/safe
  (lambda (e r c) (%objc r #t (cadr e) (caddr e) (cdddr e))))
(define-syntax objc:send/maybe-safe
  (lambda (e r c) (%objc r 'maybe (cadr e) (caddr e) (cdddr e))))
(define-syntax @
  (syntax-rules ()
    ((_ args ...) (objc:send/maybe-safe args ...))))

;; Old forms:
;; (define-macro (objc . args)
;;   `(objc:send ,@args))            ;; doesn't work (?)
;; (define-macro (objc/safe . args)
;;   `(objc:send/safe ,@args))

(define-for-syntax (%objc r safe? target arg args)
  ;; Convert a scheme-type selector string to Objective C syntax.
  ;; This simply entails uppercasing any character after a hyphen.
  ;; This is only done during macroexpansion.
  (define (objcify-selector sel)
    (let ((pieces (string-split sel "-")))
      (for-each (lambda (s) (string-upcase! s 0 1)) (cdr pieces))
      (apply string-append pieces)))
  ;; For parameter names, we accept actual keywords instead of symbols
  ;; ending in :.  Thus, depending on the current keyword-style,
  ;; initWithValue:, #:initWithValue, or :initWithValue will be
  ;; converted to "initWithValue:".  Note a single argument taking no
  ;; value requires a bare symbol, not a keyword.
  (define objc:aggregate-args
    (lambda args
      (letrec ((keyword (lambda (ls method-name params)
                          (if (null? ls)
                              (values method-name (reverse params))
                              (param (cdr ls)
                                     (string-append
                                      method-name
                                      (let ((this-method (car ls)))
                                        (cond ((keyword? this-method)
                                               (string-append (symbol->string this-method) ":"))
                                              ((symbol? this-method)
                                               (symbol->string this-method))
                                              (error 'objc "keyword expected" this-method))))
                                     params))))
               (param   (lambda (ls method-name params)
                          (if (null? ls)
                              (error 'objc "malformed method name")
                              (keyword (cdr ls)
                                       method-name
                                       (cons (car ls) params))))))
        (keyword args "" '()))))
  (let ((super? (eq? target 'super)))
    (if (null? args)
        (if super?
            `(objc:invoker ',safe? self (string-append _supersel
                                                       ,(objcify-selector (symbol->string arg))))
            `(objc:invoker ',safe? ,target ,(objcify-selector (symbol->string arg))))
        (receive (method passargs)
            (apply objc:aggregate-args (cons arg args))
          (if super?
              `(objc:invoker ',safe? self (string-append _supersel ,(objcify-selector method))
                             ,@passargs)
              `(objc:invoker ',safe? ,target ,(objcify-selector method) ,@passargs))))))

;;; Instance variables

;; This macro is slightly counterintuitive, as the name is expected to be a symbol
;; (and thus fixed at read time).  On the other hand, you can use objc:ivar-ref,
;; which takes a real string.
;; Note: these are macros, and cannot comply with SRFI-17.  However, (ivar-set! ...) is
;; shorter than (set! (ivar-ref ...)) anyway, and the (set! @foo 'bar) syntax still works.
(define-syntax ivar-ref
  (lambda (e r c)
    `(,(r 'objc:ivar-ref) ,(cadr e) ,(symbol->string (caddr e)))))
(define-syntax ivar-set!
  (lambda (e r c)
    `(,(r 'objc:ivar-set!)
      ,(cadr e)
      ,(symbol->string (caddr e))
      ,(cadddr e))))

;;; Class definitions

;;;; define-class

#|

;; objc:ivar-ref and objc:ivar-set! use the instance variable type qualifiers
;; to manage memory correctly and transparently provide access to scheme objects.

;; The type qualifiers:
;;    #:slot    An ID containing a GC root pointer to a scheme object.
;;               Scheme objects are transparently read from and assigned to these.
;;    #:wrapper An ID containing a Scheme_Object_Wrapper (which contains a GC root).
;;               Same as #:slot, with higher overhead.  Uses objc:wrap and unwrap.
;;    #:outlet  An ID whose reference count is not managed.
;;               Use these for Interface Builder outlets.
;;    ID        An ID whose reference count is automatically managed.
;;               Use these for normal Objective C instances.
;;    DBL, &c.  A regular Objective C instance variable.

;; NB!! In the interpreter, if you assign a closure to a slot: or
;; wrapper: var, it will capture self.  There is then a deadlock: self
;; cannot be released until the closure is released; the closure
;; cannot be released until the GC root is deleted, the GC root can't
;; be deleted until objc-self's dealloc is called; objc-self's dealloc
;; can't be called until its retain count is 0; and retain count
;; remains at 1 until self is released.
;;      The compiler however is smart enough to know when the closure
;; does not depend on self.  Finalization works fine in that case.

;; The superclass will be looked up for you; it does not need to be imported.

Example transformation:

(define-objc-class MyPoint NSObject ((FLT x) (FLT y))
  (define-method FLT getX (ivar-ref self x))
  (define-method VOID ((moveByX: FLT a) (Y: FLT b))
    (ivar-set! self x (+ a (ivar-ref self x)))
    (ivar-set! self y (+ b (ivar-ref self y)))))

=>

(begin
  (if (string-to-class "MyPoint")
      (warning (conc "(define-objc-class): class already registered: " 'MyPoint))
      (objc:register-class "MyPoint" (objc:string->class "NSObject")))
  (define-objc-classes MyPoint)
  (objc:set-ivars! MyPoint (list (make-objc:raw-ivar "x" objc:FLT 0)
                                (make-objc:raw-ivar "y" objc:FLT 0)))
  (objc:define-method MyPoint FLT getX (ivar-ref self x))
  (objc:define-method MyPoint VOID ((moveByX: FLT a) (Y: FLT b))
    (ivar-set! self x (+ a (ivar-ref self x)))
    (ivar-set! self y (+ b (ivar-ref self y)))))

|#

(define-syntax define-objc-class
  (lambda (e r c)
    (let ((class (cadr e))
          (super (caddr e))
          (ivars (cadddr e))
          (methods (cddddr e))
          (instance-variables (gensym)))
      `(begin
         ;; register class
         (if (string-to-class ,(symbol->string class))
             ((if (objc:allow-class-redefinition)
                  warning error)
              ,(string-append "(define-objc-class): class already registered: "
                              (symbol->string class)))
             (objc:register-class ,(symbol->string class)
                                  (objc:string->class ,(symbol->string super))))
         ;; import class
         (define-objc-classes ,class)
         (objc:class-objc?-set! ,class #f) ;; This class is not pure ObjC.

         ;; set instance variables
         (let ((,instance-variables
                (list ,@(map (lambda (ivar)
                               (let ((qualified-ID? (memq (car ivar)
                                                          '(slot: wrapper: outlet:))))
                                 (let ((name        (cadr ivar))
                                       (type        (if qualified-ID? 'ID (car ivar)))
                                       (function    (if qualified-ID? (car ivar) ivar:)))
                                   `(make-objc:ivar ,(symbol->string name)
                                                    ,(macro:type->encoding type)
                                                    0
                                                    ,function))))
                             ivars))))
           ;; Set instance vars on the Objective C side...
           (objc:set-ivars! ,class (map objc:ivar->raw ,instance-variables))
           ;; ... and in the Scheme class proxy.
           (objc:class-ivars-set! ,class
                                  (map (lambda (x)
                                         (cons (objc:ivar-name x) x))
                                       ,instance-variables))

           ;; add user methods
           ,@(map (lambda (method)
                    (let ((definer (case (car method)
                                     ((define-method -) 'objc:define-method)
                                     ((define-class-method +) 'objc:define-class-method)
                                     (else (error "invalid method definition keyword" (car method))))))
                      `(,definer ,class ,@(cdr method))))
                  methods)

           ;; Add convenience methods.  The dealloc-scheme comments explain why it gets
           ;; added to every class, not just the first Scheme generation.
           (objc:add-convenience-method! ,class
                                         "dealloc"
                                         "v@:"
                                         objc_method_dealloc))))))
  
;;;; define-method

;; Transformation:
;; (objc:define-method MyClass DBL ((sel1: INT i) (sel2: DBL d))
;;                                 (print i) (+ i d))
;; =>
;; (objc:add-method MyClass "sel1:sel2:" (list objc:DBL objc:ID objc:SEL objc:INT objc:DBL)
;;                                       (lambda (self sel i d) (print i) (+ i d)))
(define-syntax objc:define-method
  (lambda (e r c)
    (%define-method #f (cadr e) (caddr e) (cadddr e) (cddddr e))))
(define-syntax objc:define-class-method
  (lambda (e r c)
    (%define-method #t (cadr e) (caddr e) (cadddr e) (cddddr e))))

(define-for-syntax (macro:type->encoding x)   ;; internal
  (cond ((symbol? x) (string->symbol
                      (string-append "objc:" (symbol->string x))))
        (else x)))

;; Discrepancy: we compute _classname at macroexpansion time from the class -symbol-, but
;; objc:add-method creates the super selector at runtime from the actual registered class name.

(define-for-syntax %define-method
  (lambda (class? class rt args body)  ;; internal helper function
    ;; XXXX duplicated from above, workaround issues with define-for-syntax
    (define (objcify-selector sel)
      (let ((pieces (string-split sel "-")))
        (for-each (lambda (s) (string-upcase! s 0 1)) (cdr pieces))
        (apply string-append pieces)))
    (define (add-method-body method-name types names)
      (let ((self-type  (if class? 'CLASS 'ID))
            (add-method (if class? 'objc:add-class-method
                            'objc:add-method)))
        `(,add-method ,class
                      ,(objcify-selector method-name)
                      (list ,@(map (cut macro:type->encoding <>) (apply list rt self-type 'SEL types)))
                      (let ((_supersel (string-append ,(symbol->string class) ":super:")))
                        ;; _supersel is a hidden variable used by @[super..]
                        (lambda (self sel ,@names) ,@body)))))

    (if (pair? args)
        (let* ((args  (apply map list args))  ;; '((sel: type name) ...) =>
               ;; '((sel: ...) (type ...) (name ...))
               (sels  (car args))
               (types (cadr args))
               (names (caddr args))
               (method-name (apply string-append
                                   (map (lambda (x) (string-append (keyword->string x) ":"))
                                        sels))))
          (add-method-body method-name types names))
        (let ((method-name (if (keyword? args)
                               (error 'objc:define-method "argument required for selector" args)
                               (symbol->string args))))
          (add-method-body method-name '() '())))))

;; Note: type is normally a keyword; objc: will be prepended (e.g. objc:ID).  If
;; not a keyword, it is pasted verbatim so you can e.g. pass an encoded typestring.

;;; Importing classes

(define-syntax define-objc-classes
  (lambda (e r c)
    `(begin
       ,@(map
          (lambda (name)
            (cond
             ((symbol? name)
              `(define ,name (objc:string->class ,(->string name))))
             ((and (list? name) (= (length name) 2) (symbol? (car name)))
              `(define ,(car name)
                 (objc:string->class ,(->string (cadr name)))))
             (else
              (syntax-error 'define-objc-classes "invalid class name" name))))
          (cdr e)))))

;;; Read syntax

;; Felix's @[] read syntax implementation, with one tweak: all calls are maybe-safe
;; unless prefixed by unsafe: or safe:.
;; @[target sel1: x sel2: y] => (objc sel1: x sel2: y)
;; @"..."                    => creates NSString from "..."
;; @foo                      => (ivar-ref self foo)
(set-read-syntax! 
 #\@
 (let ([terminating-characters '(#\, #\; #\) #\] #\{ #\} #\')])
   (lambda (p)
     (let ((c (peek-char p)))
       (if (or (char-whitespace? c) (memq c terminating-characters))
	   '@
	   (let ((x (read p)))
	     (cond ((keyword? x) (string->keyword (string-append "@" (keyword->string x))))
		   ((symbol? x) ;(string->symbol (string-append "@" (symbol->string x)
                    `(objc:ivar-ref self ,(symbol->string x)))  ;; Can't use macro due to SRFI-17
		   ((string? x) `(force (delay (objc:nsstring ,x))))
		   ((pair? x) 
		    (cond ((eq? #:safe (car x))
                           `(objc:send/safe ,@(cdr x)))
                          ((eq? #:unsafe (car x))
                           `(objc:send ,@(cdr x)))
                          (else
                           `(objc:send/maybe-safe ,@x))))
		   (else (error "invalid read syntax for `@'" c)) ) ) ) ) ) ) )

)