@@ -32,3 +32,5 @@ NSRect-Expose

 venv

 /reading-list2org

 /dist/

+/safari2org

+/safari2org-beta

new file mode 100644

@@ -0,0 +1,43 @@

+(cl:in-package :objc.manipulators)

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

+

+(serapeum:eval-always 

+  (let (*it*)

+    (declare (special *it*))

+    (defgeneric sel (type sel)

+      (:method :around (type sel)

+               (lambda (*it*)

+                 (declare (special *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 <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)))))

@@ -21,7 +21,8 @@

                (:file "readtable" :depends-on ("package"))

                (: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"))))

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

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

 (defsystem :objc-runtime/scripting-bridge

   :description ""

@@ -35,7 +36,6 @@

   :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

@@ -39,3 +39,8 @@

    #:clear-extractors

    #:add-extractor

    #:get-plist))

+

+(uiop:define-package :objc.manipulators

+    (:use :cl :data-lens)

+  (:export :sel :ext :<> :add-index :<count)

+  (:reexport :data-lens))

@@ -1,7 +1,8 @@

 (defpackage :objc.scripting-bridge

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

+  (:import-from :objc.manipulators :defun-ct :shortcut :<> :ext :sel)

   (:use :cl :cffi)

-  (:export ))

+  (:export

+   #:app))

 (in-package :objc.scripting-bridge)

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

@@ -30,32 +31,6 @@

             (/ [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)))

@@ -75,13 +50,11 @@

 (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))

@@ -91,106 +64,56 @@

                  (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))))))

+(defmacro comment (&body b)

+  b ())

 #+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)

-

+(comment

+  (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 #\-))))

+

+  (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))

+

+  (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))))))

+

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

+    (mapc (lambda (method-name)

+            (intern-method method-name package))

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

+

+  (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))))))

+

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

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

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

+

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

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

+

+  )