Browse code

Generalize the 'Lisp' menu, opening the door to special options for other file-types

Jenga Phoenix authored on 2019-03-29 05:41:13
Showing 1 changed files
... ...
@@ -6,7 +6,9 @@
6 6
 (defparameter *editor-frame* nil "Container for the text-editor control")
7 7
 (defparameter *listener* nil "The Lisp listener interface and command interpreter")
8 8
 (defparameter *statusbar* nil "The bar at the bottom of the screen")
9
+(defparameter *menubar* nil "The menubar itself.")
9 10
 (defparameter *buffer-menubar* nil "store a reference to the buffer menubar for listing the open buffers")
11
+(defparameter *special-menubar* nil "store a reference to the 'special' menubar for filetype-specific options")
10 12
 
11 13
 ;;; allocate sequential filenames for new files
12 14
 (let ((untitled 0))
... ...
@@ -472,7 +474,11 @@
472 474
      :accessor file-path)
473 475
    (plaintextp
474 476
      :initform nil
475
-     :accessor plaintextp)))
477
+     :accessor plaintextp)
478
+   (file-type
479
+     :initarg :file-type
480
+     :initform "lisp"
481
+     :accessor file-type)))
476 482
 
477 483
 (defclass buffer-manager ()
478 484
   ((buffers
... ...
@@ -572,7 +578,9 @@
572 578
   (if (not (find-buffer buffer-manager file-path))
573 579
       (let* ((newbuffer (make-instance 'buffer :file-path file-path :master *editor-frame*))
574 580
              (text-ctrl (ltk:textbox newbuffer)))
575
-        (when open-file-p (load-text newbuffer file-path))
581
+        (when open-file-p
582
+	  (load-text newbuffer file-path)
583
+	  (setf (file-type newbuffer) (filetype-from-pathstring file-path)))
576 584
         ; Once the text control is created, enable undo. Don't want to enable it earlier
577 585
         ; as when loading files, the file load becomes the first undoable event.
578 586
         (ltk:configure text-ctrl :undo 1)
... ...
@@ -608,7 +616,8 @@
608 616
     (pathname-message)
609 617
     (ltk:pack newbuffer :side :top :fill :both :expand t)
610 618
     (ltk:force-focus newtext)
611
-    (match-paren newtext)))
619
+    (match-paren newtext)
620
+    (update-special-menu newbuffer)))
612 621
 
613 622
 (defmethod select-buffer ((buffer-manager buffer-manager) (index integer))
614 623
   (select-buffer buffer-manager
... ...
@@ -1040,36 +1049,40 @@
1040 1049
     (destructuring-bind (key action) entry
1041 1050
       (add-key-binding ltk::*tk* key action))))
1042 1051
 
1043
-(defun create-menus ()
1044
-  (let* ((mb (ltk:make-menubar))
1052
+(defmacro with-menu (menu &body body)
1053
+  `(macrolet
1054
+     ((action (name op)
1055
+        (let ((key (function-key op)))
1056
+	  (if key
1057
+	    `(ltk:make-menubutton ,',menu (format nil "~A ~A" ,name ,key) #',op)
1058
+	    `(ltk:make-menubutton ,',menu ,name #',op))))
1059
+      (text-action (name op)
1060
+        ;; an action that needs the current buffer
1061
+	(let ((key (function-key op))
1062
+	      (op-current-text
1063
+		`(lambda ()
1064
+		   (,op (get-current-text-ctrl *buffer-manager*)))))
1065
+	  (if key
1066
+	    `(ltk:make-menubutton ,',menu (format nil "~A ~A" ,name ,key)
1067
+				  ,op-current-text)
1068
+	    `(ltk:make-menubutton ,',menu ,name
1069
+				  ,op-current-text))))
1070
+      (separator ()
1071
+        `(ltk:add-separator ,',menu)))
1072
+     ,@body))
1073
+
1074
+
1075
+(defun create-menus (&key (cur-buffer nil))
1076
+  (setf *menubar* (ltk:make-menubar))
1077
+  (let* ((mb *menubar*)
1078
+	 (file-type (or (ignore-errors (file-type cur-buffer)) "lisp"))
1045 1079
          (mfile (ltk:make-menu mb #t"File"))
1046 1080
          (medit (ltk:make-menu mb #t"Edit"))
1047 1081
          (mbuffer (ltk:make-menu mb #t"Buffers"))
1048
-         (mlisp (ltk:make-menu mb #t"Lisp")))
1082
+         (mspecial (ltk:make-menu mb #t"Magic")))
1049 1083
     (setf *buffer-menubar* mbuffer)
1084
+    (setf *special-menubar* mspecial)
1050 1085
 
1051
-    (macrolet ((with-menu (menu &body body)
1052
-                 `(macrolet
1053
-                      ((action (name op)
1054
-                         (let ((key (function-key op)))
1055
-                           (if key
1056
-                               `(ltk:make-menubutton ,',menu (format nil "~A ~A" ,name ,key) #',op)
1057
-                               `(ltk:make-menubutton ,',menu ,name #',op))))
1058
-                       (text-action (name op)
1059
-                         ;; an action that needs the current buffer
1060
-                         (let ((key (function-key op))
1061
-			       (op-current-text
1062
-				 `(lambda ()
1063
-				    (,op (get-current-text-ctrl *buffer-manager*)))))
1064
-
1065
-			   (if key
1066
-			     `(ltk:make-menubutton ,',menu (format nil "~A ~A" ,name ,key)
1067
-						   ,op-current-text)
1068
-			     `(ltk:make-menubutton ,',menu ,name
1069
-						   ,op-current-text))))
1070
-                       (separator ()
1071
-                         `(ltk:add-separator ,',menu)))
1072
-                    ,@body)))
1073 1086
       (with-menu mfile
1074 1087
         (action #t"New file" on-new-file)
1075 1088
         (action #t"Open file" on-open-file)
... ...
@@ -1099,26 +1112,44 @@
1099 1112
 	(action #t"Select buffer" on-select-file)
1100 1113
 	;; sacrificial placeholder for the current buffer list
1101 1114
 	;; update the magic number in update-current-buffers when adding/removing entries
1102
-	(ltk:make-menubutton mbuffer "" nil))
1103
-      (with-menu mlisp
1104
-        (text-action #t"Macroexpand" on-macro-expand)
1105
-        (text-action #t"Copy to REPL" on-copy-sexp-to-repl)
1106
-        (ltk:make-menubutton mlisp #t"Complete symbol"
1107
-                             (lambda ()
1108
-                               (let* ((buffer (selected-buffer *buffer-manager*))
1109
-                                      (text (ltk:textbox buffer)))
1110
-                                 (unless (plaintextp buffer)
1111
-                                   (on-code-complete text)))))
1112
-        (text-action #t"CLHS lookup" on-lookup-definition)
1113
-        (separator)
1114
-        (action #t"(Re)load buffer" on-reload-file)
1115
-        (action #t"Load file" on-load-file)
1116
-        (action #t"Load ASDF" on-asdf-load)
1117
-        (separator)
1118
-        (action #t"Compile file" on-compile-file)
1119
-        (separator)
1120
-        (action #t"Invoke native debugger" on-invoke-debugger)
1121
-        (action #t"Reset listener" on-reset-listener)))))
1115
+	(ltk:make-menubutton mbuffer "" nil))))
1116
+
1117
+
1118
+(defun create-special-menu (file-type)
1119
+  (cond ((equal "lisp" file-type) (create-special-lisp-menu))
1120
+	('T (create-special-txt-menu))))
1121
+
1122
+(defun create-special-txt-menu ()
1123
+  (with-menu *special-menubar*
1124
+    (action "..." (lambda () nil))))
1125
+
1126
+(defun create-special-lisp-menu ()
1127
+  (with-menu *special-menubar* 
1128
+    (text-action #t"Macroexpand" on-macro-expand)
1129
+    (text-action #t"Copy to REPL" on-copy-sexp-to-repl)
1130
+    (ltk:make-menubutton *special-menubar* #t"Complete symbol"
1131
+     (lambda ()
1132
+        (let* ((buffer (selected-buffer *buffer-manager*))
1133
+               (text (ltk:textbox buffer)))
1134
+          (unless (plaintextp buffer)
1135
+     (on-code-complete text)))))
1136
+    (text-action #t"CLHS lookup" on-lookup-definition)
1137
+    (separator)
1138
+    (action #t"(Re)load buffer" on-reload-file)
1139
+    (action #t"Load file" on-load-file)
1140
+    (action #t"Load ASDF" on-asdf-load)
1141
+    (separator)
1142
+    (action #t"Compile file" on-compile-file)
1143
+    (separator)
1144
+    (action #t"Invoke native debugger" on-invoke-debugger)
1145
+    (action #t"Reset listener" on-reset-listener)))
1146
+
1147
+(defun update-special-menu (cur-buffer)
1148
+  (let ((mb *menubar*)
1149
+	(sb *special-menubar*)
1150
+	(file-type (or (ignore-errors (file-type cur-buffer)) "lisp")))
1151
+    (ltk:menu-delete sb 0)
1152
+    (create-special-menu file-type)))
1122 1153
 
1123 1154
 (defun on-reset-listener (&optional event)
1124 1155
   (reset *listener*))