old mode 100644

new mode 100755

@@ -7,9 +7,13 @@ mkdir -p dist

 pushd dist

 rm -rf fwoar.lisputils

 git clone https://github.com/fiddlerwoaroof/fwoar.lisputils.git

+rm -rf data-lens

+git clone https://github.com/fiddlerwoaroof/data-lens.git

 popd

 export CL_SOURCE_REGISTRY="$PWD/dist//"

 sbcl --no-userinit \

+     --disable-debugger \

      --load ~/quicklisp/setup.lisp \

-     --load build.lisp

+     --eval "(progn (pushnew :$1 *features*)

+                    (load \"build.lisp\"))"

@@ -3,12 +3,31 @@

   (load (compile-file "objc-runtime.asd")))

 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (ql:quickload '(:objc-runtime :yason :plump :cl-ppcre)))

+  (ql:quickload '(:objc-runtime :yason :plump :cl-ppcre :data-lens)))

-(load "reading-list-reader.lisp")

+#+reading-list

+(progn

+  (load "reading-list-reader.lisp")

-(eval-when (:compile-toplevel :load-toplevel :execute)

-  (sb-ext:save-lisp-and-die "reading-list2org"

-                            :toplevel (intern "MAIN"

-                                              "READING-LIST-READER")

-                            :executable t))

+  (eval-when (:compile-toplevel :load-toplevel :execute)

+    (sb-ext:save-lisp-and-die "reading-list2org"

+                              :toplevel (intern "MAIN"

+                                                "READING-LIST-READER")

+                              :executable t)))

+

+#+safari2org

+(progn

+  (load "scripting-bridge.lisp")

+  (eval-when (:compile-toplevel :load-toplevel :execute)

+    (sb-ext:save-lisp-and-die "safari2org"

+                              :toplevel (intern "SAFARI-MAIN"

+                                                "OBJC.SCRIPTING-BRIDGE")

+                              :executable t)))

+#+safari2org-beta

+(progn

+  (load "scripting-bridge.lisp")

+  (eval-when (:compile-toplevel :load-toplevel :execute)

+    (sb-ext:save-lisp-and-die "safari2org-beta"

+                              :toplevel (intern "SAFARI-2-MAIN"

+                                                "OBJC.SCRIPTING-BRIDGE")

+                              :executable t)))

@@ -49,6 +49,13 @@

   (format stream "@(~a)"

           (objc-runtime::get-method-name object)))

+(define-presentation-translator string-to-objc-class (string objc-class class-browser

+                                                             :tester ((inp) (objc-runtime:ensure-class inp))

+                                                             :tester-definitive t)

+    (inp)

+  (format *terminal-io* "~&translating ~s to an objc-class" inp)

+  (objc-runtime:ensure-class inp))

+

 (defun display-classes (frame pane)

   (updating-output (pane :unique-id (or (visible-classes frame)

                                         (classes frame))

@@ -75,7 +82,9 @@

              (format pane "   Method: ~a~%" (objc-runtime::get-method-name method)))))))

 (define-class-browser-command (com-get-methods :name t :menu t) ((the-class objc-class :gesture :select))

-  (setf (current-class *application-frame*) the-class))

+  (if (cffi:pointerp the-class)

+      (setf (current-class *application-frame*) the-class)

+      (format *terminal-io* "~&The value ~s is not a pointer to a class, but a ~s" the-class (type-of the-class))))

 (define-class-browser-command (com-refresh-classes :name t :menu t) ()

@@ -9,7 +9,8 @@

    #:define-extractor

    #:clear-extractors

    #:add-extractor

-   #:get-plist))

+   #:get-plist

+   #:objc-typecase))

 (in-package :objc-runtime.data-extractors)

 (named-readtables:in-readtable :objc-readtable)

@@ -22,3 +22,22 @@

                (:file "gcd" :depends-on ("objc-runtime"))

                (:file "objc-runtime" :depends-on ("package" "readtable" "objc-runtime-types"))

                (:file "objc-data-extractors" :depends-on ("objc-runtime" "readtable"))))

+

+(defsystem :objc-runtime/scripting-bridge

+  :description ""

+  :author "Ed L <edward@elangley.org>"

+  :license "MIT"

+  :depends-on (:objc-runtime

+               :data-lens)

+  :components ((:file "scripting-bridge")))

+

+(defsystem :objc-runtime/clim-objc-browser

+  :description ""

+  :author "Ed L <edward@elangley.org>"

+  :license "MIT"

+  :pathname #+lp-systems #p"projects:objc-lisp-bridge;" #-lp-systems nil

+  :depends-on (:objc-runtime

+               :serapeum

+               :alexandria

+               :mcclim)

+  :components ((:file "clim-objc-browser")))

@@ -47,7 +47,7 @@

 (serapeum:eval-always

   (defctype sizet

       :ulong

-      #+32-bit-target :uint))

+    #+32-bit-target :uint))

 (defcfun (class-add-ivar "class_addIvar" :library foundation)

     :boolean

@@ -64,6 +64,24 @@

                               2))

                   "@"))

+

+#+nil

+(defun make-app-delegate-class (outlets)

+  (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair

+                             #@NSObject "AppDelegate" 0)))

+    (objc-runtime:add-pointer-ivar app-delegate-class "window")

+    (objc-runtime:add-pointer-ivar app-delegate-class "delegate")

+

+    (loop for outlet in outlets do

+         (objc-runtime:add-pointer-ivar app-delegate-class outlet))

+

+    app-delegate-class))

+

+(defun %setup-objc-class (name base ivars)

+  (let ((class-pair (objc-allocate-class-pair base name 0)))

+    (loop for ivar in ivars

+         )))

+

 (defcfun (objc-class-get-name "class_getName" :library foundation)

     :string

   (cls o-class))

@@ -190,6 +208,9 @@

             (push (mem-aref methods :pointer n)

                   result)))))))

+(defmethod get-methods (f)

+  (list))

+

 (defun make-nsstring (str)

   [[#@NSString @(alloc)] @(initWithCString:encoding:) :string str :uint 1])

@@ -216,11 +237,17 @@

        do (format stream "~&~4t\"~a\" -> \"~a\"~%" class superclass))))

 (defparameter *selector-cache* (make-hash-table :test 'equal))

+(defparameter *class-cache* (make-hash-table :test 'equal))

 (serapeum:eval-always

   (defun normalize-selector-name (sel-name)

     (substitute #\: #\? sel-name)))

+(defun ensure-class (name)

+  (let ((objc-class (objc-look-up-class name)))

+    (when (and objc-class (not (null-pointer-p objc-class)))

+      (alexandria.0.dev:ensure-gethash name *class-cache* objc-class))))

+

 (defun ensure-selector (name)

   (alexandria:ensure-gethash name

                              *selector-cache*

@@ -297,7 +324,8 @@

                                    :name name

                                    :pointer objc-class)))))))

-;; TODO: should this error if there is no corresponding selector? Or should we let that fall through to message sending?

+;; TODO: should this error if there is no corresponding selector?

+;;         Or should we let that fall through to message sending?

 (defun %ensure-wrapped-objc-selector (name target-class result-type args)

   (assert (= (count #\: name)

              (length args))

@@ -26,7 +26,10 @@

    #:ensure-wrapped-objc-class

    #:add-pointer-ivar

    #:objc-msg-send-int

-   #:objc-msg-send-string))

+   #:objc-msg-send-string

+   #:make-nsstring

+   #:ensure-class

+   #:ensure-selector))

 (defpackage :objc-runtime.data-extractors

   (:use :cl )

@@ -47,7 +47,7 @@

                                                                          '(#\) #\(  #\[ #\])))

                                                        collect (read-char s t nil t))

                                                     'string)))

-                            `(objc-look-up-class ,class-name))))

+                            `(ensure-class ,class-name))))

   (:macro-char #\@ :dispatch t)

   (:dispatch-macro-char #\@ #\( (read-until (serapeum:op (char= _ #\)))

                                             'ensure-selector))

@@ -1,4 +1,5 @@

 (defpackage :objc.scripting-bridge

+  (:import-from :data-lens :defun-ct :shortcut)

   (:use :cl :cffi)

   (:export ))

 (in-package :objc.scripting-bridge)

@@ -10,10 +11,17 @@

 (use-foreign-library scripting-bridge)

-(defun get-itunes-app ()

-  [#@SBApplication @(applicationWithBundleIdentifier:) :pointer @"com.apple.iTunes"])

+(defun app (bundle-id)

+  [#@SBApplication @(applicationWithBundleIdentifier:)

+                   :pointer (objc-runtime:make-nsstring bundle-id)])

-(defun get-current-track-info (itunes)

+(defun itunes-app ()

+  (app "com.apple.iTunes"))

+

+(defun safari-app ()

+  (app "com.apple.Safari"))

+

+(defun current-track-info (itunes)

   (let* ((current-track [itunes @(currentTrack)]))

     (format t "~&Track: ~A (~v,1,0,'⋆<~>)~%Album: ~a (~v,1,0,'*<~>)~%Artist: ~a~%"

             [current-track @(name)]@

@@ -21,3 +29,168 @@

             [current-track @(album)]@

             (/ [current-track @(albumRating)]# 10)

             [current-track @(artist)]@)))

+

+(defvar *it*)

+(serapeum:eval-always 

+  (defgeneric sel (type sel)

+    (:method :around (type sel)

+             (lambda (*it*)

+               (call-next-method)))

+

+    (:method (type sel)

+      [*it* sel])

+

+    (:method ((type (eql :int)) sel)

+      [*it* sel]#)

+

+    (:method ((type (eql :string)) sel)

+      [*it* sel]s)

+

+    (:method ((type (eql :nsstring)) sel)

+      [*it* sel]@)))

+

+(defun-ct ext ()

+  (lambda (it)

+    (objc-runtime.data-extractors:extract-from-objc it)))

+

+(defun-ct <> (&rest funs)

+  (apply #'alexandria:compose funs))

+

+(defun-ct tab-info ()

+  (data-lens:juxt

+   (<> (ext) (sel t @(name)))

+   (<> (ext) (sel t @(URL)))))

+

+(data-lens:shortcut window-info data-lens:juxt

+  (sel :int @(id))

+  #'identity

+  (sel :nsstring @(name)))

+

+(defun safari-tab-info (safari)

+  (funcall (data-lens:over (tab-info))

+           (mapcan (<> (ext) (sel t @(tabs)))

+                   (objc-runtime.data-extractors:extract-from-objc

+                    [safari @(windows)]))))

+

+(defun format-tab-info (info)

+  (format t "~{~:@{** ~a~% ~a~%~}~2%~}" info))

+

+

+(defun safari-main ()

+  (format-tab-info

+   (safari-tab-info

+    (safari-app))))

+

+

+(defun count-invocations (hof)

+  (lambda (f &rest hof-args)

+    (let ((count 0))

+      (declare (dynamic-extent count))

+      (flet ((nested-lambda (&rest args)

+               (prog1 (apply f count args)

+                 (incf count))))

+        (apply hof #'nested-lambda hof-args)))))

+

+(defun-ct <count (f)

+  (lambda (c &rest v)

+    (list* c (apply f v))))

+

+(defun-ct add-index (hof f)

+  (lambda (&rest hof-args)

+    (let ((count 0))

+      (declare (dynamic-extent count))

+      (flet ((nested-lambda (&rest args)

+               (prog1 (apply f count args)

+                 (incf count))))

+        (apply hof #'nested-lambda hof-args)))))

+

+(defun get-window-tabs (window)

+  (funcall (<> 'objc-runtime.data-extractors:extract-from-objc

+               (sel t @(tabs)))

+           window))

+

+(data-lens:shortcut get-safari-info <>

+  (add-index 'mapcar 

+             (<> (fw.lu:destructuring-lambda ((c win-id win-name . tabs))

+                   (format t "~&Window: ~d ~d ~a~%~{~a~%~}~%" win-id c win-name tabs))

+                 (<count

+                  (<> (data-lens:transform-elt 1 (<> (add-index 'mapcar

+                                                                (<> (fw.lu:destructuring-lambda ((c ti u))

+                                                                      (format nil "~a ~a~%~4t~a" c ti u))

+                                                                    (<count (tab-info))))

+                                                     'get-window-tabs))

+                      'window-info))))

+  (ext)

+  (sel t @(windows)))

+

+(defun safari-2-main ()

+  (get-safari-info (safari-app)))

+

+

+

+(defun find-tab (name windows)

+  (remove-if-not (serapeum:op (serapeum:string-contains-p name _))

+                 windows

+                 :key (<> 'string-downcase 'car)))

+

+(defun current-tab (window)

+  [window @(currentTab)])

+(defun (setf current-tab) (new-value window)

+  [window @(setCurrentTab:) :pointer new-value]

+  new-value)

+

+#+nil

+(defun kebab-case (s)

+  (loop

+     for start = 0 then end

+     for end = (position-if 'upper-case-p s) then (when start (position-if 'upper-case-p s :start (1+ end)))

+     while start

+     collect (string-downcase (subseq s start end)) into parts

+     finally (return (serapeum:string-join parts #\-))))

+

+#+nil

+(defun get-method-symbol (selector-name package)

+  (funcall (alexandria:compose (lambda (x) (intern x package))

+                               #'string-upcase

+                               (lambda (x) (substitute #\- #\: 

+                                                       (string-trim ":-" x)))

+                               'kebab-case)

+           selector-name))

+

+#+nil

+(defun intern-method (selector-name package)

+  (let ((symbol (get-method-symbol selector-name package)))

+    (format t "~&~s ~s~%" symbol selector-name)

+    (if (alexandria:starts-with-subseq "set" selector-name)

+        (setf (fdefinition `(setf ,symbol))

+              (lambda (new-val receiver &rest r)

+                (declare (ignore r))

+                (objc-runtime:objc-msg-send receiver (objc-runtime::ensure-selector selector-name) :pointer new-val)))

+        (setf (fdefinition symbol)

+              (sel (objc-runtime::ensure-selector selector-name))))))

+

+#+nil

+(defun populate-package (objc-class package)

+  (mapc (lambda (method-name)

+          (intern-method method-name package))

+        (objc-runtime:get-method-names objc-class)))

+

+#+nil

+(defmacro define-objc-call (selector (&rest argument-specs) result-type &optional extractor)

+  (declare (ignorable extractor))

+  `(defun ,(get-method-symbol (cadr selector) *package*) (receiver ,@(mapcar #'car argument-specs))

+     ,(case result-type

+        (:string `(objc-runtime:objc-msg-send-string receiver ,selector ,@(mapcan #'reverse argument-specs)))

+        ((:long :int) `(objc-runtime:objc-msg-send-int receiver ,selector ,@(mapcan #'reverse argument-specs)))

+        (t `(objc-runtime:objc-msg-send receiver ,selector ,@(mapcan #'reverse argument-specs))))))

+

+#+nil

+(defmacro define-objc (() &body calls)

+  `(progn ,@(loop for call in calls

+               collect `(define-objc-call ,@call))))

+

+#+nil

+(define-objc-call @(init) () :pointer)

+#+nil

+(define-objc-call @(sharedApplication) () :pointer)

+