;; objc-data-extractor.lisp
 
 
 ;; [[file:~/git_repos/objc-lisp-bridge/README.org::*objc-data-extractor.lisp][objc-data-extractor.lisp:1]]

 (defpackage :objc-runtime.data-extractors
   (:use :cl )
   (:export
    #:extract-from-objc
    #:define-extractor
    #:clear-extractors
    #:add-extractor

    #:get-plist
    #:objc-typecase))

 (in-package :objc-runtime.data-extractors)
 (named-readtables:in-readtable :objc-readtable)
 
 (defun get-plist (file)
   [#@NSDictionary @(dictionaryWithContentsOfFile:)
                   :pointer (objc-runtime::make-nsstring file)])
 
 (defun objc-subclass-p (sub super)
   (unless (or (cffi:null-pointer-p sub)
               (cffi:null-pointer-p super))
     (or (eql sub super)
         (= [sub @(isSubclassOfClass:) :pointer [super @(class)]]#
            1))))
 
 (defun order-objc-classes (classes &rest r &key key)
   (declare (ignore key))
   (apply 'stable-sort
          (copy-seq classes)
          'objc-subclass-p
          r))
 
 (defun objc-isa (obj class)
   (unless (or (cffi:null-pointer-p obj)
               (cffi:null-pointer-p class))
     (= [obj @(isKindOfClass:) :pointer class]#
        1)))
 
 (defun objc-pick-by-type (obj pairs)
   (assoc obj
          (order-objc-classes pairs :key 'car)
          :test 'objc-isa))
 
 (serapeum:eval-always
   (defun make-cases (cases obj)
     (mapcar (serapeum:op
               `(if (objc-isa ,obj ,(car _1))
                    (progn ,@(cdr _1))))

                    cases)))

 
 (defmacro objc-typecase (form &body ((case-type &body case-handler) &rest cases))
   (alexandria:once-only (form)
     (let* ((initial-cases `((,case-type ,@case-handler) ,@(butlast cases)))
            (cases (fw.lu:rollup-list (make-cases initial-cases form)
                                      (if (eql t (caar (last cases)))
                                          `((progn ,@(cdar (last cases))))
                                          (make-cases (last cases) form)))))
       cases)))
 
 (defun map-nsarray (fn arr)
   (unless (and (cffi:pointerp arr)
                (objc-isa arr #@NSArray))
     (error "must provide a NSArray pointer"))
   (loop for x below [arr @(count)]#
      collect (funcall fn [arr @(objectAtIndex:) :int x])))
 
 (defun nsarray-contents (arr)
   (unless (and (cffi:pointerp arr)
                (objc-isa arr #@NSArray))
     (error "must provide a NSArray pointer"))
   (dotimes (n [arr @(count)]#)
     (let ((obj [arr @(objectAtIndex:) :int n ]))
       (objc-typecase obj
         (#@NSString (format t "~&string~%"))
         (#@NSArray (format t "~&array~%"))
         (#@NSDictionary (format t "~&dictionary~%"))
         (t (format t "~&other... ~s~%" (objc-runtime::objc-class-get-name
                                         (objc-runtime::object-get-class obj))))))))
 
 (defmacro funcall-some (fun &rest args)
   (alexandria:once-only (fun)
     `(if ,fun
          (funcall ,fun ,@args))))
 

 (defvar *objc-extractors* (list)
   "Functions called to extract specific data types")
 

 (defun extract-from-objc (obj)
   (objc-typecase obj
     (#@NSDate [[[[#@NSISO8601DateFormatter @(alloc)]
                  @(init)]
                 @(stringFromDate:) :pointer obj]
                @(UTF8String)]s)
     (#@NSString [obj @(UTF8String)]s)
     (#@NSNumber (parse-number:parse-number
                  (objc-runtime::extract-nsstring
                   [obj @(stringValue)])))
     (#@NSArray (map-nsarray #'extract-from-objc obj))
     (#@NSDictionary (fw.lu:alist-string-hash-table
                      (pairlis (map-nsarray #'extract-from-objc [obj @(allKeys)])
                               (map-nsarray #'extract-from-objc [obj @(allValues)]))))
     (t (or (funcall-some (cdr (objc-pick-by-type obj *objc-extractors*))
                          obj)
            obj))))

 
 (defmacro define-extractor (class (o) &body body)
   `(serapeum:eval-always
      (add-extractor ,class
                     (lambda (,o)
                       ,@body))
      *objc-extractors*))
 
 (defun clear-extractors ()
   (setf *objc-extractors* ()))
 
 (serapeum:eval-always
   (defun add-extractor (class cb)
     (unless (member class *objc-extractors* :test 'cffi:pointer-eq :key #'car)
       (setf *objc-extractors*
             (merge 'list *objc-extractors* (list (cons class cb))
                    'objc-subclass-p
                    :key 'car)))
     *objc-extractors*))

 ;; objc-data-extractor.lisp:1 ends here