From 09aa23bac811b29ba7d1bbfd5c8c55f8cdb636c3 Mon Sep 17 00:00:00 2001 From: David Botton Date: Tue, 13 Sep 2022 22:41:10 -0400 Subject: [PATCH] directory and file buttons --- tools/clog-builder-dir-win.lisp | 59 ++++++++- tools/clog-builder-projects.lisp | 11 +- tools/clog-builder-templates.lisp | 2 +- tools/clog-builder.lisp | 202 +++++++++++++++--------------- tools/dir-view.clog | 2 +- tools/dir-view.lisp | 77 ++++++++++-- 6 files changed, 230 insertions(+), 123 deletions(-) diff --git a/tools/clog-builder-dir-win.lisp b/tools/clog-builder-dir-win.lisp index ecf55cc..cba6e34 100644 --- a/tools/clog-builder-dir-win.lisp +++ b/tools/clog-builder-dir-win.lisp @@ -2,6 +2,7 @@ (defun populate-dir-win (panel d) (let ((dir (directory-namestring (uiop:truename* d)))) + (setf (current-dir panel) dir) ;; Dirs (setf (inner-html (folders panel)) "") (add-select-option (folders panel) @@ -18,8 +19,56 @@ (defun on-select-dir-win (panel) (let ((item (value (files panel)))) - (cond ((and (> (length item) 5) - (equal (subseq item (- (length item) 5)) ".clog")) - (on-new-builder-panel panel :open-file item)) - (t - (on-open-file panel :open-file item))))) + (unless (equal item "") + (cond ((and (> (length item) 5) + (equal (subseq item (- (length item) 5)) ".clog")) + (on-new-builder-panel panel :open-file item)) + (t + (on-open-file panel :open-file item)))))) + +(defun on-delete-dir-win (panel) + (let ((item (value (files panel)))) + (unless (equal item "") + (confirm-dialog panel (format nil "Delete ~A?" item) + (lambda (result) + (when result + (uiop:delete-file-if-exists item) + (populate-dir-win panel (directory-namestring item)))))))) + +(defun on-new-dir-dir-win (panel) + (input-dialog panel "Name of new directory?" + (lambda (result) + (when result + (ensure-directories-exist (format nil "~A~A/" (current-dir panel) result)) + (populate-dir-win panel (current-dir panel)))) + :title "New Directory")) + +(defun on-delete-dir-dir-win (panel d) + (let ((dir (directory-namestring (uiop:truename* d)))) + (confirm-dialog panel (format nil "Delete ~A?" dir) + (lambda (result) + (when result + (handler-case + (uiop:delete-empty-directory dir) + (error () + (alert-toast panel "Directory Delete Failure" + (format nil "Failed to delete ~A, perhaps not empty." dir)))) + (populate-dir-win panel (current-dir panel))))))) + +(defun on-rename-dir-dir-win (panel d) + (input-dialog panel "Rename directory to?" + (lambda (result) + (when result + (rename-file d (format nil "~A~A/" (current-dir panel) result)) + (populate-dir-win panel (current-dir panel)))) + :title "Rename Directory")) + +(defun on-rename-dir-win (panel) + (let ((item (value (files panel)))) + (unless (equal item "") + (input-dialog panel "Rename file to?" + (lambda (result) + (when result + (rename-file item (format nil "~A~A" (directory-namestring item) result)) + (populate-dir-win panel (current-dir panel)))) + :title "Rename File")))) diff --git a/tools/clog-builder-projects.lisp b/tools/clog-builder-projects.lisp index f02ff9a..91e7ff5 100644 --- a/tools/clog-builder-projects.lisp +++ b/tools/clog-builder-projects.lisp @@ -15,11 +15,12 @@ (projects-populate panel))))) (defun projects-view-dir (panel) - (ignore-errors - (let* ((app (connection-data-item panel "builder-app-data")) - (sel (text-value (project-list panel))) - (sys (asdf:find-system (format nil "~A" sel)))) - (on-dir-win panel :dir (asdf:system-source-directory sys))))) + (let* ((app (connection-data-item panel "builder-app-data")) + (sel (text-value (project-list panel)))) + (if (equal sel "None") + (on-dir-win panel) + (let ((sys (asdf:find-system (format nil "~A" sel)))) + (on-dir-win panel :dir (asdf:system-source-directory sys)))))) (defun projects-run (panel) (let ((val (text-value (entry-point panel)))) diff --git a/tools/clog-builder-templates.lisp b/tools/clog-builder-templates.lisp index 9e1de89..52e0f19 100644 --- a/tools/clog-builder-templates.lisp +++ b/tools/clog-builder-templates.lisp @@ -22,7 +22,7 @@ :width 500 :height 250)) (prjs (create-project-dir (window-content pwin)))) (window-center pwin) - (setf (on-done prjs) + (setf (on-done prjs) (lambda (obj) (declare (ignore obj)) (let ((filename (value (project-list prjs)))) diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp index 03499e2..8ec4b7d 100644 --- a/tools/clog-builder.lisp +++ b/tools/clog-builder.lisp @@ -1280,19 +1280,19 @@ of controls and double click to select control." (jquery editor))) (set-on-event-with-data editor "clog-macroexp" (lambda (obj data) - (let ((p (parse-integer data :junk-allowed t)) - (tv (text-value editor)) - (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))) - (let ((result (handler-case - (prin1-to-string (macroexpand lf)) - (error (condition) - (format nil "Error: ~A" condition))))) - (on-open-file obj :title-class "w3-blue" :title "macroexpand result" :text result))))) + (let ((p (parse-integer data :junk-allowed t)) + (tv (text-value editor)) + (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))) + (let ((result (handler-case + (prin1-to-string (macroexpand lf)) + (error (condition) + (format nil "Error: ~A" condition))))) + (on-open-file obj :title-class "w3-blue" :title "macroexpand result" :text result))))) ;; expand-region (js-execute editor (format nil @@ -1312,23 +1312,23 @@ of controls and double click to select control." (jquery editor))) (set-on-event-with-data editor "clog-expand-region" (lambda (obj data) - (declare (ignore obj)) - (let* ((positions (read-from-string data)) - (new-region - (judge-expand-region (text-value editor) - (car positions) - (cadr positions)))) - (js-execute editor - (format nil - "var startIndex = ~A; + (declare (ignore obj)) + (let* ((positions (read-from-string data)) + (new-region + (judge-expand-region (text-value editor) + (car positions) + (cadr positions)))) + (js-execute editor + (format nil + "var startIndex = ~A; var endIndex = ~A; var startRange = ~A.session.doc.indexToPosition(startIndex); var endRange = ~:*~A.session.doc.indexToPosition(endIndex); ~:*~A.selection.setRange(new ace.Range(startRange.row, startRange.column, endRange.row, endRange.column));" - (car new-region) - (cdr new-region) - (clog-ace::js-ace editor)))))) - + (car new-region) + (cdr new-region) + (clog-ace::js-ace editor)))))) + (set-on-change editor (lambda (obj) (let ((s (js-query obj (format nil @@ -1393,30 +1393,30 @@ var endRange = ~:*~A.session.doc.indexToPosition(endIndex); It parse the string TEXT without using READ functions." (let ((char-count 0) - (backslash 0) - exps in-dquotes-p left-dquote left-braces left-brackets) + (backslash 0) + exps in-dquotes-p left-dquote left-braces left-brackets) (sequence:dosequence (c text) - (if (= backslash 0) ;current char isn't after a backslash - (if (eql c #\\) - (incf backslash) ;if it is a backslash, mark for the next word - (if (eql c #\") ;if it is double quote, - (if in-dquotes-p ;end the last string or start a new string - (progn (setf in-dquotes-p nil) - (push (cons left-dquote (1+ char-count)) - exps)) - (setf in-dquotes-p t - left-dquote char-count)) - (if (not in-dquotes-p) ;if it isn't double quote, - (case c ;check if it's braces - (#\( (push char-count left-braces)) ;mark a new pair - (#\) (if left-braces ;end a pair - (push (cons (pop left-braces) (1+ char-count)) - exps))) - (#\[ (push char-count left-brackets)) - (#\] (if left-brackets - (push (cons (pop left-brackets) (1+ char-count)) - exps))))))) - (decf backslash)) + (if (= backslash 0) ;current char isn't after a backslash + (if (eql c #\\) + (incf backslash) ;if it is a backslash, mark for the next word + (if (eql c #\") ;if it is double quote, + (if in-dquotes-p ;end the last string or start a new string + (progn (setf in-dquotes-p nil) + (push (cons left-dquote (1+ char-count)) + exps)) + (setf in-dquotes-p t + left-dquote char-count)) + (if (not in-dquotes-p) ;if it isn't double quote, + (case c ;check if it's braces + (#\( (push char-count left-braces)) ;mark a new pair + (#\) (if left-braces ;end a pair + (push (cons (pop left-braces) (1+ char-count)) + exps))) + (#\[ (push char-count left-brackets)) + (#\] (if left-brackets + (push (cons (pop left-brackets) (1+ char-count)) + exps))))))) + (decf backslash)) (incf char-count)) exps)) @@ -1424,58 +1424,58 @@ It parse the string TEXT without using READ functions." "Judge the next wider region to expand to." (declare (string text) (number start) (number end)) (let ((selected (subseq text start end))) - (or (let ((word-range ;expand to current word - (ignore-errors - (let* ((edge-scanner (ppcre:create-scanner "[^\\w]"))) - (if (not (ppcre:scan edge-scanner selected)) ;there isn't word edge in selected - (cons (- start ;search for previous word edge - (or (car (ppcre:all-matches - edge-scanner - (reverse (subseq text 0 start)))) - start)) ;if nothing, mark from beginning to end. - (+ end ;search for next word edge - (or (car (ppcre:all-matches edge-scanner - (subseq text end))) - (- (length text) end))))))))) - (if (not (equal word-range (cons start end))) - word-range)) ;return if it isn't same with selected - (let ((symbol-range ;expand to current symbol - ;; just like expand to word, but search for blanks, braces and double quote. - (ignore-errors - (let* ((edge-scanner (ppcre:create-scanner "[\\s\\(\\)\\[\\]\"]"))) - (if (not (ppcre:scan edge-scanner selected)) - (cons (- start - (or (car (ppcre:all-matches edge-scanner - (reverse (subseq text 0 start)))) - start)) - (+ end - (or (car (ppcre:all-matches edge-scanner - (subseq text end))) - (- (length text) end))))))))) - (if (not (equal symbol-range (cons start end))) - symbol-range)) - (alexandria:if-let ;expand to curren expression/string - ((sexp (ignore-errors - (car (sort (delete nil - (mapcar ;find wider expressions contained selected - #'(lambda (pair) - (if (or (and (< (car pair) start) - (> (cdr pair) end)) - (and (= (car pair) start) - (> (cdr pair) end)) - (and (< (car pair) start) - (= (cdr pair) end))) - pair)) - (scan-exps text))) - #'(lambda (obj1 obj2) ;sort it to find the smallest - (> (car obj1) (car obj2)))))))) - (if (or (= (car sexp) start) ;judge "inner" or "outer" to select - (= (cdr sexp) end) - (and (= (1+ (car sexp)) start) - (= (1- (cdr sexp)) end))) - sexp - (cons (1+ (car sexp)) (1- (cdr sexp)))) - (cons start end))))) ;if no expressions, select all + (or (let ((word-range ;expand to current word + (ignore-errors + (let* ((edge-scanner (ppcre:create-scanner "[^\\w]"))) + (if (not (ppcre:scan edge-scanner selected)) ;there isn't word edge in selected + (cons (- start ;search for previous word edge + (or (car (ppcre:all-matches + edge-scanner + (reverse (subseq text 0 start)))) + start)) ;if nothing, mark from beginning to end. + (+ end ;search for next word edge + (or (car (ppcre:all-matches edge-scanner + (subseq text end))) + (- (length text) end))))))))) + (if (not (equal word-range (cons start end))) + word-range)) ;return if it isn't same with selected + (let ((symbol-range ;expand to current symbol + ;; just like expand to word, but search for blanks, braces and double quote. + (ignore-errors + (let* ((edge-scanner (ppcre:create-scanner "[\\s\\(\\)\\[\\]\"]"))) + (if (not (ppcre:scan edge-scanner selected)) + (cons (- start + (or (car (ppcre:all-matches edge-scanner + (reverse (subseq text 0 start)))) + start)) + (+ end + (or (car (ppcre:all-matches edge-scanner + (subseq text end))) + (- (length text) end))))))))) + (if (not (equal symbol-range (cons start end))) + symbol-range)) + (alexandria:if-let ;expand to curren expression/string + ((sexp (ignore-errors + (car (sort (delete nil + (mapcar ;find wider expressions contained selected + #'(lambda (pair) + (if (or (and (< (car pair) start) + (> (cdr pair) end)) + (and (= (car pair) start) + (> (cdr pair) end)) + (and (< (car pair) start) + (= (cdr pair) end))) + pair)) + (scan-exps text))) + #'(lambda (obj1 obj2) ;sort it to find the smallest + (> (car obj1) (car obj2)))))))) + (if (or (= (car sexp) start) ;judge "inner" or "outer" to select + (= (cdr sexp) end) + (and (= (1+ (car sexp)) start) + (= (1- (cdr sexp)) end))) + sexp + (cons (1+ (car sexp)) (1- (cdr sexp)))) + (cons start end))))) ;if no expressions, select all ;; Menu handlers diff --git a/tools/dir-view.clog b/tools/dir-view.clog index f829e5b..86a83dd 100644 --- a/tools/dir-view.clog +++ b/tools/dir-view.clog @@ -1 +1 @@ -
\ No newline at end of file +
\ No newline at end of file diff --git a/tools/dir-view.lisp b/tools/dir-view.lisp index 8723305..ea3b030 100644 --- a/tools/dir-view.lisp +++ b/tools/dir-view.lisp @@ -1,35 +1,92 @@ ;;;; CLOG Builder generated code - modify original clog file (in-package :clog-tools) (defclass dir-view (clog:clog-panel) - ((files :reader files) (divider :reader divider) - (folders :reader folders))) + ((rename-button :reader rename-button) + (del-button :reader del-button) (open-button :reader open-button) + (rename-dir-button :reader rename-dir-button) + (del-dir-button :reader del-dir-button) + (new-dir-button :reader new-dir-button) + (open-dir-button :reader open-dir-button) (files :reader files) + (divider :reader divider) (folders :reader folders) + (current-dir :accessor current-dir :initform "."))) (defun create-dir-view (clog-obj &key (hidden nil) (class nil) (html-id nil) (auto-place t)) (let ((panel (change-class (clog:create-div clog-obj :content - "
" + "
" :hidden hidden :class class :html-id html-id :auto-place auto-place) 'dir-view))) + (setf (slot-value panel 'rename-button) + (attach-as-child clog-obj "CLOGB387211077419" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'del-button) + (attach-as-child clog-obj "CLOGB3872109096" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'open-button) + (attach-as-child clog-obj "CLOGB3872109095" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'rename-dir-button) + (attach-as-child clog-obj "CLOGB387211008317" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'del-dir-button) + (attach-as-child clog-obj "CLOGB387210909815" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'new-dir-button) + (attach-as-child clog-obj "CLOGB3872109094" :clog-type + 'clog:clog-form-element :new-id t)) + (setf (slot-value panel 'open-dir-button) + (attach-as-child clog-obj "CLOGB3872109093" :clog-type + 'clog:clog-form-element :new-id t)) (setf (slot-value panel 'files) - (attach-as-child clog-obj "CLOGB3872102946" :clog-type + (attach-as-child clog-obj "CLOGB3872109092" :clog-type 'clog:clog-select :new-id t)) (setf (slot-value panel 'divider) - (attach-as-child clog-obj "CLOGB3872102945" :clog-type + (attach-as-child clog-obj "CLOGB3872109091" :clog-type 'clog:clog-div :new-id t)) (setf (slot-value panel 'folders) - (attach-as-child clog-obj "CLOGB3872102944" :clog-type + (attach-as-child clog-obj "CLOGB3872109090" :clog-type 'clog:clog-select :new-id t)) (let ((target (folders panel))) (declare (ignorable target)) (populate-dir-win panel "./")) - (clog:set-on-change (folders panel) - (lambda (target) - (declare (ignorable target)) - (populate-dir-win panel (value target)))) + (clog:set-on-mouse-double-click (folders panel) + (lambda (target data) + (declare (ignorable target data)) + (populate-dir-win panel (value target)))) (clog:set-on-double-click (files panel) (lambda (target) (declare (ignorable target)) (on-select-dir-win panel))) + (clog:set-on-click (open-dir-button panel) + (lambda (target) + (declare (ignorable target)) + (populate-dir-win panel (value (folders panel))))) + (clog:set-on-click (new-dir-button panel) + (lambda (target) + (declare (ignorable target)) + (on-new-dir-dir-win panel))) + (clog:set-on-click (del-dir-button panel) + (lambda (target) + (declare (ignorable target)) + (on-delete-dir-dir-win panel + (value (folders panel))))) + (clog:set-on-click (rename-dir-button panel) + (lambda (target) + (declare (ignorable target)) + (on-rename-dir-dir-win panel + (value (folders panel))))) + (clog:set-on-click (open-button panel) + (lambda (target) + (declare (ignorable target)) + (on-select-dir-win panel))) + (clog:set-on-click (del-button panel) + (lambda (target) + (declare (ignorable target)) + (on-delete-dir-win panel))) + (clog:set-on-click (rename-button panel) + (lambda (target) + (declare (ignorable target)) + (on-rename-dir-win panel))) panel)) \ No newline at end of file