Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv2026/Drei
Modified Files:
drei.lisp packages.lisp syntax.lisp views.lisp
Added Files:
modes.lisp
Log Message:
Added support for "modes" (roughly similar to Emacs' minor-modes) to Drei.
--- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/25 06:46:21 1.23
+++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/28 10:08:28 1.24
@@ -219,7 +219,7 @@
;;;
;;; The basic Drei class.
-(defclass drei ()
+(defclass drei (modual-mixin)
((%view :initform (make-instance 'textual-drei-syntax-view)
:initarg :view
:accessor view
@@ -288,6 +288,25 @@
(defmethod (setf active) (new-val (drei drei))
(setf (active (view drei)) new-val))
+(defmethod available-modes append ((modual drei))
+ (available-modes (view modual)))
+
+(defmethod mode-applicable-p or ((modual drei) mode-name)
+ (mode-applicable-p (view modual) mode-name))
+
+(defmethod mode-enabled-p or ((modual drei) mode-name)
+ (mode-enabled-p (view modual) mode-name))
+
+(defmethod enable-mode ((modual drei) mode-name &rest initargs)
+ (if (mode-applicable-p (view modual) mode-name)
+ (apply #'enable-mode (view modual) mode-name initargs)
+ (call-next-method)))
+
+(defmethod disable-mode ((modual drei) mode-name)
+ (if (mode-applicable-p (view modual) mode-name)
+ (disable-mode (view modual) mode-name)
+ (call-next-method)))
+
(defun add-view-cursors (drei)
"Add the cursors desired by the Drei view to the editor-pane of
the Drei instance."
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/27 15:22:54 1.26
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/28 10:08:33 1.27
@@ -138,7 +138,8 @@
(defpackage :drei-syntax
(:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils)
- (:export #:syntax #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:cursor-positions
+ (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp
+ #:define-syntax #:*default-syntax* #:cursor-positions
#:syntax-command-table #:additional-command-tables #:define-syntax-command-table
#:eval-option
#:define-option-for-syntax
@@ -277,7 +278,12 @@
#:*foreground-color*
#:*background-color*
#:*show-mark*
- #:*use-tabs-for-indentation*))
+ #:*use-tabs-for-indentation*
+
+ #:view-mode #:syntax-mode
+ #:applicable-modes
+ #:define-mode #:define-view-mode #:define-syntax-mode
+ #:define-mode-toggle-commands))
(defpackage :drei-motion
(:use :clim-lisp :drei-base :drei-buffer :drei-syntax)
--- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/10 21:25:12 1.8
+++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/28 10:08:34 1.9
@@ -22,7 +22,7 @@
(in-package :drei-syntax)
-(defclass syntax (name-mixin)
+(defclass syntax (name-mixin modual-mixin)
((%buffer :initarg :buffer :reader buffer)
(%command-table :initarg :command-table
:initform (error "A command table has not been provided for this syntax")
@@ -32,6 +32,13 @@
:accessor updater-fns))
(:documentation "The base class for all syntaxes."))
+(defgeneric syntax-command-tables (syntax)
+ (:documentation "Returns additional command tables provided by
+`syntax'.")
+ (:method-combination append)
+ (:method append ((syntax syntax))
+ (list (command-table syntax))))
+
(defun syntaxp (object)
"Return T if `object' is an instance of a syntax, NIL
otherwise."
--- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/19 17:17:37 1.7
+++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/28 10:08:35 1.8
@@ -403,7 +403,7 @@
;;;
;;; View classes.
-(defclass drei-view (tabify-mixin subscriptable-name-mixin)
+(defclass drei-view (tabify-mixin subscriptable-name-mixin modual-mixin)
((%active :accessor active
:initform t
:initarg :active
@@ -445,6 +445,12 @@
(print-unreadable-object (view stream :type t :identity t)
(format stream "name: ~a ~a" (name view) (subscript view))))
+(defmethod available-modes append ((modual drei-view))
+ *global-modes*)
+
+(defmethod mode-applicable-p or ((modual drei-view) mode-name)
+ (mode-applicable-p (syntax modual) mode-name))
+
(defgeneric synchronize-view (view &key &allow-other-keys)
(:documentation "Synchronize the view with the object under
observation - what exactly this entails, and what keyword
@@ -583,6 +589,19 @@
(buffer-size view) (size (buffer view)))
(synchronize-view view :force-p t))
+(defmethod mode-enabled-p or ((modual drei-syntax-view) mode-name)
+ (mode-enabled-p (syntax modual) mode-name))
+
+(defmethod enable-mode ((modual drei-syntax-view) mode-name &rest initargs)
+ (if (mode-applicable-p (syntax modual) mode-name)
+ (apply #'enable-mode (syntax modual) mode-name initargs)
+ (call-next-method)))
+
+(defmethod disable-mode ((modual drei-syntax-view) mode-name)
+ (if (mode-applicable-p (syntax modual) mode-name)
+ (disable-mode (syntax modual) mode-name)
+ (call-next-method)))
+
(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer)
changed-region)
(with-accessors ((prefix-size prefix-size)
@@ -668,7 +687,7 @@
(make-instance 'mark-cursor :view view :output-stream output-stream))))
(defmethod view-command-tables append ((view textual-drei-syntax-view))
- (list (command-table (syntax view))))
+ (syntax-command-tables (syntax view)))
(defmethod use-editor-commands-p ((view textual-drei-syntax-view))
t)
--- /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:50 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:50 1.1
;;; -*- Mode: Lisp; Package: DREI -*-
;;; (c) copyright 2007-2008 by
;;; Troels Henriksen (athas(a)sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;;
;;; This file contains the implementation of the infrastructure for
;;; Drei "modes", loosely equivalent to Emacs minor modes. They modify
;;; aspects of the behavior of a view or syntax.
(in-package :drei)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The general mode protocol and macros.
(defvar *global-modes* '()
"A list of the names of modes globally available to Drei
instances. Do not use this list to retrieve modes, use the
function `available-modes' instead. The modes on this list are
available to all Drei variants.")
(defun applicable-modes (drei)
"Return a list of the names of all modes applicable for
`drei'."
(remove-if-not #'(lambda (mode)
(mode-applicable-p (view drei) mode))
(available-modes drei)))
(defclass view-mode (mode)
()
(:documentation "The superclass for all view modes."))
(defclass syntax-mode (mode)
()
(:documentation "The superclass for all syntax modes."))
(defmacro define-mode (name (&rest superclasses)
(&rest slot-specs)
&rest options)
"Define a toggable Drei mode. It is essentially a class, with
the provided `name', `superclasses', `slot-specs' and
`options'. It will automatically be a subclass of `mode'. Apart
from the normal class options, `options' can also have a
`:global' option, which when true signifies that the mode is
globally available to all Drei instances. This option is true by
default. Note that modes created via this macro are not
applicable to anything."
(let ((global t)
(actual-options '()))
(dolist (option options)
(case (first option)
(:global (setf global (second option)))
(t (push option actual-options))))
`(progn
(defclass ,name (,@superclasses mode)
(,@slot-specs)
,@actual-options)
(defmethod enabled-modes append ((modual ,name))
'(,name))
,(when global `(push ',name *global-modes*)))))
(defmacro define-view-mode (name (&rest superclasses)
(&rest slot-specs)
&rest options)
"Define a mode (as `define-mode') that is applicable to
views. Apart from taking the same options as `define-mode', it
also takes an `:applicable-views' option (nil by default) that is
a list of views the mode should be applicable to. Multiple uses
of this option are cumulative."
(let ((applicable-views '())
(actual-options '()))
(dolist (option options)
(case (first option)
(:applicable-views (setf applicable-views
(append applicable-views
(rest option))))
(t (push option actual-options))))
`(progn
(define-mode ,name (,@superclasses view-mode)
(,@slot-specs)
,@actual-options)
,@(loop for view in applicable-views
collecting `(defmethod mode-directly-applicable-p or
((view ,view) (mode-name (eql ',name)))
t)))))
(defmacro define-syntax-mode (name (&rest superclasses)
(&rest slot-specs)
&rest options)
"Define a mode (as `define-mode') that is applicable to
syntaxes. Apart from taking the same options as `define-mode', it
also takes an `:applicable-syntaxes' option (nil by default) that
is a list of syntaxes the mode should be applicable to. Multiple
uses of this option are cumulative."
(let ((applicable-syntaxes '())
(actual-options '()))
(dolist (option options)
(case (first option)
(:applicable-syntaxes (setf applicable-syntaxes
(append applicable-syntaxes
(rest option))))
(t (push option actual-options))))
`(progn
(define-mode ,name (,@superclasses syntax-mode)
(,@slot-specs)
,@actual-options)
,@(loop for syntax in applicable-syntaxes
collecting `(defmethod mode-directly-applicable-p or
((syntax ,syntax) (mode-name (eql ',name)))
t)))))
(defmacro define-mode-toggle-commands (command-name
(mode-name &optional (string-form (capitalize (string mode-name))))
&key (name t) command-table)
"Define a simple command (named `command-name') for toggling
the mode named by `mode-name' on and off. `String-form' is the
name of the mode that will be put in the docstring, `name' and
`command-table' work as in `define-command'."
(check-type command-name symbol)
(check-type mode-name symbol)
(check-type string-form string)
`(define-command (,command-name :name ,name :command-table ,command-table)
()
,(concatenate 'string "Toggle " string-form " mode.")
(if (mode-enabled-p *drei-instance* ',mode-name)
(disable-mode *drei-instance* ',mode-name)
(enable-mode *drei-instance* ',mode-name))))
