;;; Copyright (c) 1991-2018 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen ;;; see LICENSE for conditions ;;; When porting to MCL, old toplevel.lsp was split into toplevel.lsp which should ;;; be generic CL and this file which has the commands to create the actual menu ;;; ACL port - redefine menu commands ;;; split file again - menus.lsp is independent between ACL and MCL ;;; Note - this file now must be read in before any of the other ;;; CLIM files which associate menus etc with *lkb-top-frame* (in-package :clim-user) (eval-when (:compile-toplevel :load-toplevel :execute) ;; In the CLIM 2 specification, *default-text-style* is a constant so in theory it should ;; not be setf-able - but we want somehow to make sure the default face is :sans-serif. ;; Also, for most kinds of text in the LKB, McCLIM's default :normal size (= 14 point) ;; looks too big on displays at 100-120 ppi. (unless (constantp '*default-text-style*) (setf (symbol-value '*default-text-style*) (merge-text-styles (make-text-style :sans-serif nil #+:mcclim :small #-:mcclim nil) *default-text-style*)))) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(*lkb-top-frame* *lkb-top-stream* *last-directory* set-up-lkb-interaction enable-type-interactions disable-type-interactions))) (defvar *lkb-menu-type* :core) (defvar *lkb-top-frame* nil) (defvar *lkb-top-stream* nil) (defvar *lkb-top-process* nil) (defvar *last-directory* nil) (defvar *complete-lisp-close* nil) ;;; Commands which can be disabled, and abstract (non-CLIM) menus (defvar *lkb-menu-disabled-list* nil "list of menu items that may be disabled, i.e. are not available-p :always") (defvar *lkb-menu-grammar-file-list* nil) (defvar *lkb-menu-mrs-list* nil) (defvar *lkb-menu* nil) ;;; Classes for abstract menus (defclass menu-thing () ((menu-title :initarg :menu-title :type string :accessor menu-title) (available-p :initarg :available-p :accessor available-p))) (defclass menu (menu-thing) ((menu-items :initarg :menu-items :accessor menu-items))) #+:mcclim (eval-when (:load-toplevel :compile-toplevel :execute) (when (eq (nth-value 1 (find-symbol "MENU-ITEM" :clim)) :external) (shadow '(clim:menu-item)))) ; obliquely mentioned in CLIM 2 spec, so McCLIM exports it (defclass menu-item (menu-thing) ((menu-value :initarg :value :accessor menu-value))) ;;; Create abstract (system-independent) menu items: each is either a leaf or has submenus (defun make-menu-item (&key name value available-p) (let ((menu (make-instance 'menu-item :menu-title name :value value :available-p available-p))) (unless (eql available-p :always) (push (intern (concatenate 'string "COM-" name)) *lkb-menu-disabled-list*)) (when (eql available-p :grammar) (push (intern (concatenate 'string "COM-" name)) *lkb-menu-grammar-file-list*)) (when (eql available-p :mrs) (push (intern (concatenate 'string "COM-" name)) *lkb-menu-mrs-list*)) menu)) (defun make-lkb-submenu-item (&key menu-title menu-items available-p) (let ((menu (make-instance 'menu :menu-title menu-title :menu-items menu-items :available-p available-p))) (unless (eql available-p :always) (push (intern (concatenate 'string "MENU-" menu-title)) *lkb-menu-disabled-list*)) (when (eql available-p :mrs) (push (intern (concatenate 'string "MENU-" menu-title)) *lkb-menu-mrs-list*)) menu)) (defun update-enabled-commands (frame) (dolist (command *lkb-menu-disabled-list*) (setf (command-enabled command frame) nil)) ;; if we have the name of grammar script file then there has been an attempt to ;; load a grammar (when lkb::*current-grammar-load-file* (enable-type-interactions))) (defun enable-type-interactions nil (when *lkb-top-frame*; only relevant when Lkb Top frame exists (dolist (command *lkb-menu-disabled-list*) (when (or lkb::*mrs-loaded* (not (member command *lkb-menu-mrs-list*))) (setf (command-enabled command *lkb-top-frame*) t))))) (defun disable-type-interactions nil (when *lkb-top-frame* (dolist (command *lkb-menu-disabled-list*) (unless (member command *lkb-menu-grammar-file-list*) (setf (command-enabled command *lkb-top-frame*) nil))))) (defun enable-grammar-reload-interactions nil (when *lkb-top-frame* (dolist (command *lkb-menu-grammar-file-list*) (setf (command-enabled command *lkb-top-frame*) t)))) (defun enable-mrs-interactions nil (when (and *lkb-top-frame* lkb::*mrs-loaded*) (dolist (command *lkb-menu-mrs-list*) (setf (command-enabled command *lkb-top-frame*) t)))) ;;; Translate abstract menu structure into CLIM command menus (defgeneric construct-menu (menu table)) (defmethod construct-menu ((menu menu) table) (let ((new-table (make-command-table (intern (concatenate 'string "MENU-" (menu-title menu))) :inherit-from '(global-command-table) :errorp nil))) (push new-table (command-table-inherit-from (find-command-table 'lkb-top-command-table))) (add-menu-item-to-command-table table (menu-title menu) :menu new-table :errorp nil) (mapc #'(lambda (submenu) (construct-menu submenu new-table)) (menu-items menu)))) (defmethod construct-menu ((menu menu-item) table) (let (#+:sbcl (sb-ext:*muffled-warnings* t) ; suppress COM- redefinition warnings (name (intern (concatenate 'string "COM-" (menu-title menu))))) (eval `(define-command (,name :menu ,(menu-title menu) :command-table ,table) () (lkb::execute-menu-command (funcall (quote ,(menu-value menu))) (format t "~%While attempting to execute menu command ~A" ,(menu-title menu))))))) (define-command-table menu-quit) (define-command (com-quit :menu "Click to confirm quit" :command-table menu-quit) () (setq *complete-lisp-close* t) (frame-exit *application-frame*)) ;;; set-up-lkb-interaction is the entry point for LKB top-level graphical interaction (defun set-up-lkb-interaction (&optional (system-type (or *lkb-menu-type* :core))) (unless lkb::*lkb-frame-lock* (setq lkb::*lkb-frame-lock* (mp:make-process-lock))) (cond ((make:getenv "LKB_GUI_EXTERNAL") ; are we running inside Trollet or similar? nil) ((and *lkb-top-frame* (not (eq (frame-state *lkb-top-frame*) :disowned))) ;; an Lkb Top window already exists so don't make another (enable-frame *lkb-top-frame*) (raise-frame *lkb-top-frame*) *lkb-top-frame*) (t (set-up-lkb-menus system-type) (setq *lkb-top-process* (mp:run-function "start-lkb-frame" #'run-lkb-top-menu #+:allegro excl:*initial-terminal-io* #-:allegro lkb::*initial-terminal-io*))))) (defun set-up-lkb-menus (system-type) ;; first create abstract menu structure in *lkb-menu* for current system-type (setq *lkb-menu-disabled-list* nil) (setq *lkb-menu-grammar-file-list* nil) (setq *lkb-menu-mrs-list* nil) (ecase system-type (:core (create-mini-lkb-system-menu)) (:big (create-big-lkb-system-menu)) #+:ignore (:full (create-lkb-system-menu)) #+:ignore (:yadu (create-yadu-system-menu))) ;; now (re-)create Lkb Top command table and populate it from abstract menu (make-command-table 'lkb-top-command-table :inherit-from '(menu-quit global-command-table) :menu '(("Quit" :menu menu-quit)) :errorp nil) (dolist (submenu (menu-items *lkb-menu*)) (construct-menu submenu 'lkb-top-command-table))) ;;; Expand and shrink command menu in an existing Lkb Top frame, invoked from commands ;;; in frame itself (defun expand-lkb-menu nil (setq *lkb-menu-type* :big) (change-lkb-menus *lkb-menu-type*)) (defun shrink-lkb-menu nil (setq *lkb-menu-type* :core) (change-lkb-menus *lkb-menu-type*)) (defun change-lkb-menus (system-type) ;; change command menus on an existing Lkb Top - may only be called from a frame command (set-up-lkb-menus system-type) (setf (frame-command-table *lkb-top-frame*) (find-command-table 'lkb-top-command-table)) (update-enabled-commands *lkb-top-frame*) ;; in Allegro CLIM, (setf frame-command-table) does not update the menu bar, and ;; it seems the only way to get it to update is by forcing a re-layout of the frame. ;; Other, more obvious ways don't work. Thanks to Greg Siegle for this suggestion ;; http://ml.cddddr.org/clim/911231/msg00411.html #-:mcclim (mp:run-function "Scroll to end" ;; re-layout leaves vertical scroll bar inconsistent with window contents then throws ;; out to command loop - fix up #'(lambda () (sleep 0.2) (ignore-errors (scroll-to-end *lkb-top-stream*) (window-refresh *lkb-top-stream*)))) #-:mcclim (setf (frame-current-layout *lkb-top-frame*) (if (eq (frame-current-layout *lkb-top-frame*) 'default) 'alternate 'default))) (defun scroll-to-end (stream) (let ((vp-height (bounding-rectangle-height (pane-viewport-region stream))) (y-max (bounding-rectangle-max-y stream))) (scroll-extent stream 0 (max 0 (- y-max vp-height))))) ;;; Lkb Top frame, containing command menu and output logging pane (define-application-frame lkb-top () () (:menu-bar #+:mcclim lkb-top-command-table ; otherwise :command-table value overlooked #-:mcclim t) (:command-table (lkb-top-command-table)) (:panes (lkb-top-pane (make-pane 'application-pane :text-cursor nil :end-of-line-action :allow ; looks better than :wrap :end-of-page-action :scroll #+:mcclim :text-margins #+:mcclim '(:left 3 :top 3 :bottom 3 :right 3) :background +white+ :foreground +black+ :text-style (lkb::lkb-dialog-font) :display-time t :output-record (make-instance 'clim:standard-sequence-output-history)))) (:layouts (default #+:mcclim (scrolling () lkb-top-pane) ;; in Allegro CLIM, we can't set a left-hand text margin and the pane wouldn't ;; scroll if we instead inserted a spacing pane inside the scroller, so instead put ;; some spacing outside #-:mcclim #1=(spacing (:thickness 1) (scrolling () lkb-top-pane))) #-:mcclim (alternate #1#))) ; identical layout, used by Allegro CLIM change-lkb-menus (defun run-lkb-top-menu (background-stream) (let ((frame #-:mcclim (make-application-frame 'lkb-top :pretty-name "Lkb Top" :width 640 :height 250) #+:mcclim (lkb::with-dialog-positioning (left top) 640 (declare (ignore top)) (make-application-frame 'lkb-top :pretty-name "Lkb Top" :width 640 :height 250 :left left :top 100)))) (setq lkb::*lkb-background-stream* background-stream) (setq *lkb-top-frame* frame) (unwind-protect (run-frame-top-level frame) (when *complete-lisp-close* ;; ;; with the latest set of CLIM patches, it appears we need to rebind the ;; standard streams to avoid an `operation on closed stream' error(), ;; while shutting down the Lisp. not quite sure why, but alas. ;; (8-feb-08; oe) #+:allegro (let* ((stream excl:*initial-terminal-io*) (*standard-output* stream) (*debug-io* stream) (*terminal-io* stream) (*standard-input* stream) (*error-output* stream) (*query-io* stream) (*trace-output* stream)) (excl:exit 0 :no-unwind t :quiet t)) #+:lispworks (lw:quit :ignore-errors-p t) #+:ccl (ccl:quit 0) #+:sbcl (sb-ext:exit) #-(or :allegro :lispworks :ccl :sbcl) (error "no known mechanism to shutdown Lisp (see `topmenu.lsp')"))))) (defmethod run-frame-top-level :before ((frame lkb-top) &key &allow-other-keys) ;; we can't set *lkb-top-stream* any earlier than here, since up to this point there ;; is no guarantee that any panes have been attached to the frame (setq *lkb-top-stream* (find-pane-named frame 'lkb-top-pane)) (update-enabled-commands frame) ;; !!! With McCLIM and SBCL, in some unexplained circumstances the window does not ;; draw itself fully - in that case calling (sleep 0.2) here might fix the problem ) (defmethod frame-exit :before ((frame lkb-top) #+:allegro &rest #+:allegro keys) ;; the &rest argument in Allegro CLIM is not documented in the Franz CLIM 2 User Guide, ;; and also conflicts with the CLIM 2 spec #+:allegro (declare (ignore keys)) (setq *lkb-top-frame* nil) (setq *lkb-top-process* nil) ;; deal gracefully with attempts to send output to a closed lkb-top frame (setq *lkb-top-stream* lkb::*lkb-background-stream*)) #+(or :sbcl :ccl) (defun shutdown-external-processes () ;; in case the LUI process doesn't quit when its input and output streams are closed ;; by the underlying Lisp system when it exits #+:lui (ignore-errors (lkb::lui-shutdown)) ;; ditto the [incr tsdb()] podium #+(and :tsdb :linux) (ignore-errors (funcall (find-symbol "SHUTDOWN-PODIUM" :tsdb)))) #+(or :sbcl :ccl) (eval-when (:load-toplevel :execute) (pushnew #'shutdown-external-processes #+:sbcl sb-ext:*exit-hooks* #+:ccl ccl:*lisp-cleanup-functions*)) #| (defun user-exit-lkb-frame (frame) ;; Check if user really wants to do this. By default, exit Lisp as ;; well. For stand-alone application, always exit Lisp as well. (if (lep:lep-is-running) (let ((result (lkb::ask-user-for-multiple-choice "Really exit?" 'Lisp 'LKB 'Cancel))) (cond ((eq result 'lkb) (frame-exit frame)) ((eq result 'lisp) (setf *complete-lisp-close* t) (frame-exit frame)) (t nil))) (when (lkb::lkb-y-or-n-p "Really exit the system?") (setf *complete-lisp-close* t) (frame-exit frame)))) |# #+:allegro (defun dump-lkb nil (if lkb::*current-grammar-load-file* (progn (lkb::lkb-beep) (format t "~%Dump system will not work after a grammar has been loaded")) (let ((image-location (lkb::ask-user-for-new-pathname (format nil "File for image (local file advised)")))) (when image-location ;;; apparently 5.0 requires that the file be .dxl ;;; this lets the user give another type - since they may know more ;;; than I do, but issues a warning message #+(and :allegro (version>= 5 0)) (let ((image-type (pathname-type image-location))) (unless image-type (setf image-location (merge-pathnames image-location (make-pathname :type "dxl")))) (when image-type (unless (equal image-type "dxl") (format t "~%Warning - image type was ~A when dxl was expected" image-type)))) (setf *last-directory* nil) (setf excl:*restart-init-function* #'set-up-lkb-interaction) (excl:dumplisp :name image-location) (lkb::lkb-beep) (format t "~%Image saved~%") nil)))) #+(or :ccl :sbcl) (defun dump-lkb (image-location) (cond (lkb::*current-grammar-load-file* (lkb::lkb-beep) (warn "Dump system call ignored since a grammar has been loaded")) #+:mcclim (*lkb-top-frame* (lkb::lkb-beep) (warn "Dump system call ignored since CLIM frames have been created")) (t (let ((build-date (string-trim '(#\newline) (with-output-to-string (str) (lkb::write-time-readably str))))) (flet ((restore-dumped-lkb () (format t "Welcome to LKB ~A (built with ~A, ~A)~%~%" cl-user::*lkb-version* (lisp-implementation-type) build-date) (force-output) #+:sbcl (sb-debug::enable-debugger) #+:sbcl (setf sb-impl::*descriptor-handlers* nil) #+(or :sbcl :ccl) (make::set-lkb-memory-management-parameters) (in-package :lkb) (setq *print-pretty* nil) (setq lkb::*initial-terminal-io* *terminal-io*) ;; reset portable utilities temp directory since it's machine-specific (uiop/stream:setup-temporary-directory) ;; allow McCLIM to find alternative default fonts #+:mcclim (mcclim-truetype::autoconfigure-fonts) (unless (probe-file (lkb::lkb-tmp-dir)) (warn "Temporary files directory ~A does not exist" (lkb::lkb-tmp-dir))) (lkb::start-lkb t))) #+:ccl (progn (setq ccl::*inhibit-greeting* t) (setq ccl:*restore-lisp-functions* (list #'restore-dumped-lkb)) (ccl:save-application image-location :prepend-kernel t)) ; then lisp quits #+:sbcl (progn (setq sb-int:*repl-read-form-fun* #'make::sbcl-repl-read-form) (setq sb-ext:*init-hooks* (list #'restore-dumped-lkb)) (sb-debug::disable-debugger) (sb-ext:save-lisp-and-die (pathname image-location) :executable t :save-runtime-options t #+:sb-core-compression :compression #+:sb-core-compression 6) (sb-ext:exit))))))) ;;; Lkb Top menu commands that are time-consuming can run in a new process (defun parse-sentences-batch nil (mp:run-function "Batch parse" #'lkb::parse-sentences)) ;;; Run a command, directing ordinary output to Lkb Top's application pane (defun invoke-with-output-to-top (cont) ;; !!! take care with *lkb-top-stream* here since it will be the background terminal ;; stream if user has closed Lkb Top (unwind-protect (let ((*standard-output* *lkb-top-stream*) (*error-output* *lkb-top-stream*) #-:mcclim (*trace-output* *lkb-top-stream*) ; output from tracing can overwhelm Lkb Top ;; ;; _fix_me_ ;; we believe that debug output from the CLIM patches may cause a ;; force-output() on *debug-io* to raise an error(), when running ;; in a background process. (13-feb-08; oe) ;; ;; JAC - although redirecting input or I/O streams to an output-only ;; stream might be necessary in Allegro, it's a bad idea in general ;; #+(and :allegro (not :logon)) (*debug-io* *lkb-top-stream*) #+:allegro (*terminal-io* *lkb-top-stream*) #+:allegro (*standard-input* *lkb-top-stream*) #+:allegro (*query-io* *lkb-top-stream*)) ;; suspending a thread from another can easily result in deadlock - and indeed ;; this is not implemented in acl-compat.mp #-:acl-compat (when (not (eq mp:*current-process* *lkb-top-process*)) (mp:process-add-arrest-reason *lkb-top-process* :output)) ;; (when (extended-output-stream-p *standard-output*) #-:mcclim (setf (stream-recording-p *standard-output*) t) ; Allegro CLIM resets it? (stream-close-text-output-record *standard-output*)) ; ensure complete recording (multiple-value-prog1 (funcall cont) (finish-output))) #-:acl-compat (mp:process-revoke-arrest-reason *lkb-top-process* :output)))