mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
607 lines
36 KiB
Common Lisp
607 lines
36 KiB
Common Lisp
(in-package :clog-tools)
|
|
|
|
;; Local file utilities
|
|
|
|
(defun read-file (infile &key clog-obj (report-errors t) if-does-not-exist)
|
|
"Read local file named INFILE"
|
|
(handler-case
|
|
(with-open-file (instream infile :direction :input :if-does-not-exist if-does-not-exist)
|
|
(when instream
|
|
(let* ((len (file-length instream))
|
|
(string (make-string len))
|
|
(pos (read-sequence string instream)))
|
|
(subseq string 0 pos))))
|
|
(error (condition)
|
|
(when report-errors
|
|
(if clog-obj
|
|
(alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
|
|
(format t "Error: ~A" condition)))
|
|
nil)))
|
|
|
|
(defun write-file (string outfile &key clog-obj (action-if-exists :rename))
|
|
"Write local file named OUTFILE"
|
|
(check-type action-if-exists (member nil :error :new-version :rename :rename-and-delete
|
|
:overwrite :append :supersede))
|
|
(handler-case
|
|
(with-open-file (outstream outfile :direction :output :if-exists action-if-exists)
|
|
(when outstream
|
|
(write-sequence string outstream)))
|
|
(error (condition)
|
|
(if clog-obj
|
|
(alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
|
|
(format t "Error: ~A" condition)))))
|
|
|
|
(defun on-open-file-ext (obj &key open-file popup)
|
|
(if (and *open-external-with-emacs* open-file)
|
|
(swank:ed-in-emacs open-file)
|
|
(let ((win (window-to-top-by-title obj open-file)))
|
|
(if win
|
|
(window-focus win)
|
|
(if *open-external-using-clog-popups*
|
|
(let ((pop (open-clog-popup obj
|
|
:specs (if (or popup *open-external-source-in-popup*)
|
|
"width=640,height=480"
|
|
"")
|
|
:name "_blank")))
|
|
(if pop
|
|
(let ((app (connection-data-item obj "builder-app-data")))
|
|
(setf (connection-data-item pop "builder-app-data") app)
|
|
(set-html-on-close pop "Connection Lost")
|
|
(clog-gui-initialize pop :parent-desktop-obj obj)
|
|
(add-class pop *builder-window-desktop-class*)
|
|
(if open-file
|
|
(setf (title (html-document pop)) (file-namestring open-file))
|
|
(setf (title (html-document pop)) "CLOG Builder Source Editor"))
|
|
(on-open-file pop :open-file open-file :maximized t))
|
|
(on-open-file obj :open-file open-file)))
|
|
(open-window (window (connection-body obj))
|
|
(if open-file
|
|
(format nil "/source-editor?open-file=~A"
|
|
open-file)
|
|
"/source-editor?open-file=%20")
|
|
:specs (if (or popup *open-external-source-in-popup*)
|
|
"width=800,height=600"
|
|
"")
|
|
:name "_blank"))))))
|
|
|
|
(defun on-open-file (obj &key open-file
|
|
(title "New Source Editor")
|
|
text
|
|
(title-class *builder-title-class*)
|
|
lisp-package
|
|
regex
|
|
show-find
|
|
force-mode
|
|
is-console
|
|
left top
|
|
(editor-use-console-for-evals *editor-use-console-for-evals*)
|
|
has-time-out
|
|
maximized
|
|
(closer-html "×"))
|
|
"Open a new text editor"
|
|
(let ((win (window-to-top-by-title obj open-file)))
|
|
(when win
|
|
(let ((pop (connection-data-item obj "clog-popup")))
|
|
(when pop
|
|
(close-window pop)
|
|
(window-focus win))
|
|
(when regex
|
|
(focus (window-param win))
|
|
(js-execute obj (format nil "~A.find({regExp:true,needle:'~A',caseSensitive:false})"
|
|
(clog-ace::js-ace (window-param win)) (escape-string regex))))
|
|
(when show-find
|
|
(clog-ace:execute-command (window-param win) "find")))
|
|
win)
|
|
(unless win
|
|
(let* ((app (connection-data-item obj "builder-app-data"))
|
|
(*menu-bar-class* *builder-menu-bar-class*)
|
|
(*menu-bar-drop-down-class* *builder-menu-bar-drop-down-class*)
|
|
(*menu-item-class* *builder-menu-item-class*)
|
|
(*menu-window-select-class* *builder-menu-window-select-class*)
|
|
(*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*)
|
|
(win (create-gui-window obj :title title
|
|
:title-class title-class
|
|
:left left :top top
|
|
:width 700 :height 480
|
|
:has-pinner is-console
|
|
:keep-on-top is-console
|
|
:closer-html closer-html
|
|
:client-movement *client-side-movement*))
|
|
(box (create-panel-box-layout (window-content win)
|
|
:left-width 0 :right-width 0
|
|
:top-height 66 :bottom-height 0))
|
|
(menu (create-gui-menu-bar (top-panel box) :main-menu nil))
|
|
(m-file (create-gui-menu-drop-down menu :content "File"))
|
|
(m-load (create-gui-menu-item m-file :content "load"))
|
|
(m-save (create-gui-menu-item m-file :content "save (cmd/ctrl-s)"))
|
|
(m-saveas (create-gui-menu-item m-file :content "save as.."))
|
|
(m-revert (create-gui-menu-item m-file :content "revert"))
|
|
(m-emacs (unless (or (in-clog-popup-p obj)
|
|
is-console)
|
|
(create-gui-menu-item m-file :content "open in emacs")))
|
|
(m-ntab (unless (or (in-clog-popup-p obj)
|
|
is-console)
|
|
(create-gui-menu-item m-file :content "open in new tab")))
|
|
(m-edit (create-gui-menu-drop-down menu :content "Edit"))
|
|
(m-undo (create-gui-menu-item m-edit :content "undo (cmd/ctrl-z)"))
|
|
(m-redo (create-gui-menu-item m-edit :content "redo (shift cmd/ctrl-z)"))
|
|
(m-copy (create-gui-menu-item m-edit :content "copy (cmd/ctrl-c)"))
|
|
(m-paste (create-gui-menu-item m-edit :content "paste (cmd/ctrl-v)"))
|
|
(m-cut (create-gui-menu-item m-edit :content "cut (cmd/ctrl-x)"))
|
|
(m-del (create-gui-menu-item m-edit :content "delete (del)"))
|
|
(m-ppqs (create-gui-menu-item m-edit :content "quote quotes selection"))
|
|
(m-lisp (create-gui-menu-drop-down menu :content "Lisp"))
|
|
(m-efrm (create-gui-menu-item m-lisp :content "evaluate form (cmd/alt-[)"))
|
|
(m-esel (create-gui-menu-item m-lisp :content "evaluate selection"))
|
|
(m-test (create-gui-menu-item m-lisp :content "evaluate all"))
|
|
(m-brwsp (create-gui-menu-item m-lisp :content "system browse at point (cmd/alt-.)"))
|
|
(m-brws (create-gui-menu-item m-lisp :content "system browse selection"))
|
|
(m-desc (create-gui-menu-item m-lisp :content "describe selection"))
|
|
(m-doc (create-gui-menu-item m-lisp :content "documentation on selection"))
|
|
(m-apro (create-gui-menu-item m-lisp :content "apropos on selection"))
|
|
(m-pprt (create-gui-menu-item m-lisp :content "adjust tabs at point (ctrl/alt-t)"))
|
|
(m-ppr (create-gui-menu-item m-lisp :content "adjust tabs file"))
|
|
(m-pprs (create-gui-menu-item m-lisp :content "adjust tabs selection"))
|
|
(m-help (create-gui-menu-drop-down menu :content "Help"))
|
|
(m-helpk (create-gui-menu-item m-help :content "keyboard help"))
|
|
(tool-bar (create-div (top-panel box) :class title-class))
|
|
(btn-class *builder-icons-class*)
|
|
(btn-copy (create-img tool-bar :alt-text "copy" :url-src img-btn-copy :class btn-class))
|
|
(btn-paste (create-img tool-bar :alt-text "paste" :url-src img-btn-paste :class btn-class))
|
|
(btn-cut (create-img tool-bar :alt-text "cut" :url-src img-btn-cut :class btn-class))
|
|
(btn-del (create-img tool-bar :alt-text "delete" :url-src img-btn-del :class btn-class))
|
|
(btn-undo (create-img tool-bar :alt-text "undo" :url-src img-btn-undo :class btn-class))
|
|
(btn-redo (create-img tool-bar :alt-text "redo" :url-src img-btn-redo :class btn-class))
|
|
(btn-save (create-img tool-bar :alt-text "save" :url-src img-btn-save :class btn-class))
|
|
(btn-load (create-img tool-bar :alt-text "load" :url-src img-btn-load :class btn-class))
|
|
(spacer1 (create-span tool-bar :content " "))
|
|
(btn-efrm (create-button tool-bar :content "Eval Form" :class (format nil "w3-tiny ~A" btn-class)))
|
|
(btn-esel (create-button tool-bar :content "Eval Sel" :class (format nil "w3-tiny ~A" btn-class)))
|
|
(btn-test (create-button tool-bar :content "Eval All" :class (format nil "w3-tiny ~A" btn-class)))
|
|
(btn-brws (create-button tool-bar :content "Browse" :class (format nil "w3-tiny ~A" btn-class)))
|
|
(spacer2 (create-span tool-bar :content " "))
|
|
(btn-help (create-span tool-bar :content "?" :class "w3-tiny w3-ripple"))
|
|
(content (center-panel box))
|
|
(pac-line (create-form-element content :text :class *builder-package-class*))
|
|
(ace (clog-ace:create-clog-ace-element content))
|
|
(status (create-div content :class *builder-status-bar-class*))
|
|
(lisp-file t)
|
|
(is-dirty nil)
|
|
(last-date nil)
|
|
(file-name (or open-file
|
|
"")))
|
|
(declare (ignore spacer1 spacer2))
|
|
(setf (window-param win) ace)
|
|
(add-class menu "w3-small")
|
|
(set-on-click (create-span (window-icon-area win)
|
|
:content (format nil "~A " (code-char #x26F6))
|
|
:auto-place :top)
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(set-geometry win
|
|
:top (menu-bar-height win)
|
|
:left *builder-left-panel-size*
|
|
:height "" :width ""
|
|
:bottom 5 :right 0)
|
|
(clog-ace:resize (window-param win))
|
|
(set-on-window-move win nil)
|
|
(set-on-window-move win (lambda (obj)
|
|
(setf (width obj) (width obj))
|
|
(setf (height obj) (height obj))))))
|
|
(set-on-click (create-span (window-icon-area win)
|
|
:content "- "
|
|
:auto-place :top)
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(setf (hiddenp win) t)))
|
|
(setf (overflow (top-panel box)) :visible) ; let menus leave the top panel
|
|
(setf (z-index m-file) 10) ; fix for ace editor gutter overlapping menu
|
|
(when has-time-out
|
|
(bordeaux-threads:make-thread
|
|
(lambda ()
|
|
(loop
|
|
(setf (window-title win)
|
|
(format nil "~A - window closes in ~A seconds" title has-time-out))
|
|
(cond ((< (decf has-time-out) 0)
|
|
(window-close win)
|
|
(return))
|
|
(t
|
|
(sleep 1)))))))
|
|
(when maximized
|
|
(window-maximize win))
|
|
(when text
|
|
(setf (text-value ace) text))
|
|
(set-on-change pac-line
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(setf (current-editor-is-lisp app) (text-value pac-line))))
|
|
(set-on-window-focus win
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(if lisp-file
|
|
(setf (current-editor-is-lisp app) (text-value pac-line))
|
|
(setf (current-editor-is-lisp app) nil))))
|
|
(add-class tool-bar title-class)
|
|
(setf (advisory-title btn-paste) "paste")
|
|
(setf (advisory-title btn-cut) "cut")
|
|
(setf (advisory-title btn-del) "delete")
|
|
(setf (advisory-title btn-undo) "undo")
|
|
(setf (advisory-title btn-redo) "redo")
|
|
(setf (advisory-title btn-save) "save - shift-click save as...")
|
|
(setf (advisory-title btn-load) "load")
|
|
(setf (advisory-title btn-efrm) "evaluate form")
|
|
(setf (advisory-title btn-esel) "evaluate selection")
|
|
(setf (advisory-title btn-test) "evaluate")
|
|
(setf (advisory-title btn-brws) "system browse at point")
|
|
(setf (height btn-copy) "12px")
|
|
(setf (height btn-paste) "12px")
|
|
(setf (height btn-cut) "12px")
|
|
(setf (height btn-del) "12px")
|
|
(setf (height btn-undo) "12px")
|
|
(setf (height btn-redo) "12px")
|
|
(setf (height btn-save) "12px")
|
|
(setf (height btn-load) "12px")
|
|
(setf (height btn-efrm) "12px")
|
|
(setf (height btn-esel) "12px")
|
|
(setf (height btn-test) "12px")
|
|
(setf (height btn-brws) "12px")
|
|
(setf (height btn-help) "12px")
|
|
(setf (width btn-efrm) "43px")
|
|
(setf (width btn-esel) "43px")
|
|
(setf (width btn-test) "43px")
|
|
(setf (positioning ace) :absolute)
|
|
(setf (positioning status) :absolute)
|
|
(set-geometry pac-line :units "" :top "20px" :left "0px"
|
|
:right "0px" :height "22px" :width "100%")
|
|
(setf (place-holder pac-line) "Current Package")
|
|
(if lisp-package
|
|
(setf (text-value pac-line) lisp-package)
|
|
(setf (text-value pac-line) "clog-user"))
|
|
(setf (current-editor-is-lisp app) (text-value pac-line))
|
|
(set-geometry ace :units "" :width "" :height ""
|
|
:top "22px" :bottom "20px" :left "0px" :right "0px")
|
|
(clog-ace:resize ace)
|
|
(set-geometry status :units "" :width "" :height "20px"
|
|
:bottom "0px" :left "0px" :right "0px")
|
|
(labels ((on-help (obj)
|
|
(declare (ignore obj))
|
|
(alert-dialog win
|
|
"<table>
|
|
<tr><td>cmd/ctrl-,</td><td>Configure editor</td></tr>
|
|
<tr><td>F1</td><td>Command Palette</td></tr>
|
|
<tr><td>cmd/alt-.</td><td>Launch system browser</td></tr>
|
|
<tr><td>cmd/alt-[</td><td>Evaluate form</td></tr>
|
|
<tr><td>cmd/ctrl-s</td><td>Save</td></tr>
|
|
<tr><td>ctrl/alt-t</td><td>Adjust tabs at cursor</td></tr>
|
|
<tr><td>ctrl/alt-=</td><td>Expand region</td></tr>
|
|
<tr><td>opt/alt-m</td><td>Macroexpand</td></tr>
|
|
</table><p><a target='_blank' href='https://github.com/ajaxorg/ace/wiki/Default-Keyboard-Shortcuts'>Default Keybindings</a>"
|
|
:width 400 :height 400
|
|
:title "Help")))
|
|
(set-on-click btn-help #'on-help)
|
|
(set-on-click m-helpk #'on-help))
|
|
(set-on-window-size-done win
|
|
(lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:resize ace)))
|
|
(labels ((set-is-dirty (status)
|
|
(cond (status
|
|
(setf is-dirty t)
|
|
(set-outline btn-save :yellow :solid :thin))
|
|
(t
|
|
(setf is-dirty nil)
|
|
(set-outline btn-save :green :solid :thin))))
|
|
(open-file-name (fname)
|
|
(window-focus win)
|
|
(handler-case
|
|
(when fname
|
|
(setf last-date (file-write-date fname))
|
|
(setf file-name fname)
|
|
(setf (window-title win) fname)
|
|
(let ((c (or (read-file fname :clog-obj obj) "")))
|
|
(cond ((or (equalp (pathname-type fname) "lisp")
|
|
(equalp (pathname-type fname) "asd"))
|
|
(setf (clog-ace:mode ace) "ace/mode/lisp")
|
|
(setf (text-value pac-line) (get-package-from-string c))
|
|
(setf lisp-file t)
|
|
(setf (current-editor-is-lisp app) (text-value pac-line)))
|
|
(t
|
|
(setf lisp-file nil)
|
|
(setf (current-editor-is-lisp app) nil)
|
|
(if (equalp (pathname-type fname) "clog")
|
|
(setf (clog-ace:mode ace) "ace/mode/html")
|
|
(setf (clog-ace:mode ace) (clog-ace:get-mode-from-extension ace fname)))))
|
|
(setf (clog-ace:text-value ace) c)))
|
|
(error (condition)
|
|
(unless text
|
|
(alert-toast obj "File Error" (format nil "Error: ~A" condition))
|
|
(format t "Error: ~A" condition)))))
|
|
(load-file (obj)
|
|
(server-file-dialog obj "Load Source" (directory-namestring (if (equal file-name "")
|
|
(current-project-dir app)
|
|
file-name))
|
|
(lambda (fname)
|
|
(open-file-name fname)
|
|
(set-is-dirty nil)))))
|
|
(when (and open-file
|
|
(not (equalp open-file " "))
|
|
(not (equalp open-file "")))
|
|
(open-file-name open-file))
|
|
(when force-mode
|
|
(setf (clog-ace:mode ace) force-mode)
|
|
(setf (current-editor-is-lisp app) nil))
|
|
(setup-lisp-ace ace status)
|
|
(when is-console
|
|
(setf (clog-ace:mode ace) "ace/mode/plain_text")
|
|
(clog-ace:set-auto-completion ace nil)
|
|
(set-on-change ace nil))
|
|
(when regex
|
|
(focus ace)
|
|
(js-execute obj (format nil "~A.find('~A',{caseSensitive:false,regExp:true})"
|
|
(clog-ace::js-ace ace) regex)))
|
|
(when show-find
|
|
(clog-ace:execute-command ace "find"))
|
|
(set-on-click btn-load (lambda (obj) (load-file obj)))
|
|
(set-on-click m-load (lambda (obj) (load-file obj)))
|
|
(set-on-click m-revert (lambda (obj)
|
|
(declare (ignore obj))
|
|
(set-is-dirty nil)
|
|
(open-file-name file-name)))
|
|
(set-on-input ace (lambda (obj)
|
|
(declare (ignore obj))
|
|
(set-is-dirty t)))
|
|
(set-on-event ace "clog-save-ace"
|
|
(lambda (obj)
|
|
(unless (equal file-name "")
|
|
(add-class btn-save "w3-animate-top")
|
|
(write-file (text-value ace) file-name :clog-obj obj)
|
|
(set-is-dirty nil)
|
|
(setf last-date (file-write-date file-name))
|
|
(sleep .5)
|
|
(remove-class btn-save "w3-animate-top"))))
|
|
(flet ((save (obj data &key save-as)
|
|
(cond ((or (equal file-name "")
|
|
(getf data :shift-key)
|
|
save-as)
|
|
(server-file-dialog obj "Save Source As.." (if (equal file-name "")
|
|
(current-project-dir app)
|
|
file-name)
|
|
(lambda (fname)
|
|
(window-focus win)
|
|
(when fname
|
|
(setf file-name fname)
|
|
(setf (window-title win) fname)
|
|
(add-class btn-save "w3-animate-top")
|
|
(write-file (text-value ace) fname :clog-obj obj)
|
|
(set-is-dirty nil)
|
|
(setf last-date (file-write-date fname))
|
|
(sleep .5)
|
|
(remove-class btn-save "w3-animate-top"))
|
|
:initial-filename file-name)))
|
|
(t
|
|
(cond ((or (not (probe-file file-name))
|
|
(eql last-date (file-write-date file-name)))
|
|
(add-class btn-save "w3-animate-top")
|
|
(write-file (text-value ace) file-name :clog-obj obj)
|
|
(set-is-dirty nil)
|
|
(setf last-date (file-write-date file-name))
|
|
(sleep .5)
|
|
(remove-class btn-save "w3-animate-top"))
|
|
(t
|
|
(let ((*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*))
|
|
(confirm-dialog obj "File changed on file system. Save?"
|
|
(lambda (result)
|
|
(when result
|
|
(add-class btn-save "w3-animate-top")
|
|
(write-file (text-value ace) file-name :clog-obj obj)
|
|
(set-is-dirty nil)
|
|
(setf last-date (file-write-date file-name))
|
|
(sleep .5)
|
|
(remove-class btn-save "w3-animate-top")))))))))))
|
|
(when m-emacs
|
|
(set-on-click m-emacs (lambda (obj)
|
|
(when is-dirty
|
|
(save obj nil))
|
|
(swank:ed-in-emacs file-name)
|
|
(window-close win))))
|
|
(when m-ntab
|
|
(set-on-click m-ntab (lambda (obj)
|
|
(when is-dirty
|
|
(save obj nil))
|
|
(window-close win)
|
|
(on-open-file-ext obj :open-file file-name))))
|
|
(set-on-window-can-close win
|
|
(lambda (obj)
|
|
(cond (is-dirty
|
|
(let ((*default-title-class* *builder-title-class*)
|
|
(*default-border-class* *builder-border-class*))
|
|
(confirm-dialog obj "Save File?"
|
|
(lambda (result)
|
|
(set-is-dirty nil)
|
|
(when result
|
|
(save obj nil))
|
|
(window-close win))
|
|
:ok-text "Yes" :cancel-text "No"))
|
|
nil)
|
|
(t
|
|
t))))
|
|
(set-on-mouse-click btn-save (lambda (obj data)
|
|
(save obj data)))
|
|
(set-on-click m-saveas (lambda (obj)
|
|
(save obj nil :save-as t)))
|
|
(set-on-click m-save (lambda (obj)
|
|
(save obj nil))))
|
|
(labels ((buf-add ()
|
|
(let ((val (clog-ace:selected-text ace)))
|
|
(unless (equal val "")
|
|
(place-inside-top-of (window-content (copy-history-win app))
|
|
(create-text-area (window-content (copy-history-win app))
|
|
:class "w3-input"
|
|
:value val
|
|
:auto-place nil)))))
|
|
(copy ()
|
|
(buf-add)
|
|
(clog-ace:clipboard-copy ace))
|
|
(cut ()
|
|
(buf-add)
|
|
(clog-ace:clipboard-cut ace)))
|
|
(set-on-click btn-copy (lambda (obj)
|
|
(declare (ignore obj))
|
|
(copy)))
|
|
(set-on-click m-copy (lambda (obj)
|
|
(declare (ignore obj))
|
|
(copy)))
|
|
(set-on-click btn-cut (lambda (obj)
|
|
(declare (ignore obj))
|
|
(cut)))
|
|
(set-on-click m-cut (lambda (obj)
|
|
(declare (ignore obj))
|
|
(cut))))
|
|
(set-on-click btn-paste (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:clipboard-paste ace)))
|
|
(set-on-click m-paste (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:clipboard-paste ace)))
|
|
(set-on-click btn-del (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "del")))
|
|
(set-on-click m-del (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "del")))
|
|
(set-on-click btn-undo (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "undo")))
|
|
(set-on-click m-undo (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "undo")))
|
|
(set-on-click btn-redo (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "redo")))
|
|
(set-on-click m-redo (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "redo")))
|
|
(set-on-click m-desc (lambda (obj)
|
|
(let ((r (make-array '(0) :element-type 'base-char
|
|
:fill-pointer 0 :adjustable t)))
|
|
(with-output-to-string (s r)
|
|
(let ((*standard-output* s))
|
|
(describe (find-symbol (string-upcase (clog-ace:selected-text ace))
|
|
(string-upcase (text-value pac-line)))))
|
|
(on-open-file obj :title-class "w3-purple" :title "describe selection"
|
|
:text r)))))
|
|
(set-on-click m-apro (lambda (obj)
|
|
(let ((r (make-array '(0) :element-type 'base-char
|
|
:fill-pointer 0 :adjustable t)))
|
|
(with-output-to-string (s r)
|
|
(let ((*standard-output* s))
|
|
(apropos (clog-ace:selected-text ace)))
|
|
(on-open-file obj :title-class "w3-purple" :title "apropos selection"
|
|
:text r)))))
|
|
(set-on-click m-brws (lambda (obj)
|
|
(declare (ignore obj))
|
|
(on-new-sys-browser ace :search (clog-ace:selected-text ace))))
|
|
(set-on-click btn-brws (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "find-definition")))
|
|
(set-on-click m-brwsp (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "find-definition")))
|
|
(set-on-click m-doc (lambda (obj)
|
|
(open-window (window (connection-body obj))
|
|
(format nil "http://l1sp.org/search?q=~A"
|
|
(clog-ace:selected-text ace)))))
|
|
(set-on-click m-pprt (lambda (obj)
|
|
(declare (ignore obj))
|
|
(clog-ace:execute-command ace "adjust-tabs")))
|
|
(set-on-click m-ppr (lambda (obj)
|
|
(declare (ignore obj))
|
|
(let ((r (make-array '(0) :element-type 'base-char
|
|
:fill-pointer 0 :adjustable t)))
|
|
(with-output-to-string (s r)
|
|
(with-input-from-string (n (text-value ace))
|
|
(let ((*standard-output* s))
|
|
(indentify:indentify n))))
|
|
(setf (text-value ace) r)
|
|
(set-is-dirty t))))
|
|
(set-on-click m-pprs (lambda (obj)
|
|
(declare (ignore obj))
|
|
(let ((r (make-array '(0) :element-type 'base-char
|
|
:fill-pointer 0 :adjustable t)))
|
|
(with-output-to-string (s r)
|
|
(with-input-from-string (n (clog-ace:selected-text ace))
|
|
(let ((*standard-output* s))
|
|
(indentify:indentify n))))
|
|
(js-execute ace (format nil "~A.insert('~A',true)"
|
|
(clog-ace::js-ace ace)
|
|
(escape-string r)))
|
|
(set-is-dirty t))))
|
|
(set-on-click m-ppqs (lambda (obj)
|
|
(declare (ignore obj))
|
|
(let ((r (clog-ace:selected-text ace)))
|
|
(setf r (ppcre:regex-replace-all "\"" r "\\\""))
|
|
(js-execute ace (format nil "~A.insert('~A',true)"
|
|
(clog-ace::js-ace ace)
|
|
(escape-string r)))
|
|
(set-is-dirty t))))
|
|
(labels ((eval-form (obj)
|
|
(let ((p (parse-integer
|
|
(js-query obj
|
|
(format nil "~A.session.doc.positionToIndex (~A.selection.getCursor(), 0);"
|
|
(clog-ace::js-ace ace)
|
|
(clog-ace::js-ace ace)))
|
|
:junk-allowed t))
|
|
(tv (text-value ace))
|
|
(lf nil)
|
|
(cp 0))
|
|
(loop
|
|
(setf (values lf cp) (read-from-string tv nil nil :start cp))
|
|
(unless lf (return nil))
|
|
(when (> cp p) (return lf)))
|
|
(when lf
|
|
(let ((result (capture-eval lf
|
|
:capture-console (not editor-use-console-for-evals)
|
|
:capture-result (not editor-use-console-for-evals)
|
|
:clog-obj (connection-body obj)
|
|
:eval-in-package (text-value pac-line))))
|
|
(if editor-use-console-for-evals
|
|
(on-open-console obj)
|
|
(on-open-file obj :title-class "w3-blue" :title "form eval"
|
|
:has-time-out *editor-delay-on-eval-form* :text result))))))
|
|
(eval-selection (obj)
|
|
(let ((val (clog-ace:selected-text ace)))
|
|
(unless (equal val "")
|
|
(let ((result (capture-eval val :clog-obj obj
|
|
:capture-console (not editor-use-console-for-evals)
|
|
:capture-result (not editor-use-console-for-evals)
|
|
:eval-in-package (text-value pac-line))))
|
|
(if editor-use-console-for-evals
|
|
(on-open-console obj)
|
|
(on-open-file obj :title-class "w3-blue" :title "selection eval"
|
|
:has-time-out *editor-delay-on-eval-sel* :text result))))))
|
|
(eval-file (obj)
|
|
(let ((val (text-value ace)))
|
|
(unless (equal val "")
|
|
(let ((result (capture-eval val :clog-obj obj
|
|
:capture-console (not editor-use-console-for-evals)
|
|
:capture-result (not editor-use-console-for-evals)
|
|
:eval-in-package (text-value pac-line))))
|
|
(if editor-use-console-for-evals
|
|
(on-open-console obj)
|
|
(on-open-file obj :title-class "w3-blue" :title "file eval"
|
|
:has-time-out *editor-delay-on-eval-file* :text result)))))))
|
|
(set-on-click btn-esel (lambda (obj)
|
|
(eval-selection obj)))
|
|
(set-on-click m-esel (lambda (obj)
|
|
(eval-selection obj)))
|
|
(set-on-click btn-efrm (lambda (obj)
|
|
(eval-form obj)))
|
|
(set-on-click m-efrm (lambda (obj)
|
|
(eval-form obj)))
|
|
(set-on-click btn-test (lambda (obj)
|
|
(eval-file obj)))
|
|
(set-on-click m-test (lambda (obj)
|
|
(eval-file obj))))
|
|
win)))))
|