Commit 1767d844 authored by Troels Henriksen's avatar Troels Henriksen

Changed Climacs to use a view-paradigm. Somewhat hacky, probably buggy.

parent e8d33b1d
This diff is collapsed.
......@@ -58,7 +58,7 @@
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
(let*((token (expression-at-mark (point) (current-syntax))))
(let* ((token (expression-at-mark (current-syntax) (point))))
(if token
(macroexpand-token (current-syntax) token)
(esa:display-message "Nothing to expand at point."))))
......@@ -69,7 +69,7 @@ The expanded expression will be displayed in a
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
(let ((token (expression-at-mark (point) (current-syntax))))
(let ((token (expression-at-mark (current-syntax) (point))))
(if token
(macroexpand-token (current-syntax) token t)
(esa:display-message "Nothing to expand at point."))))
......@@ -86,7 +86,7 @@ Compiler notes will be displayed in a seperate buffer."
"Compile the file open in the current buffer.
This command does not load the file after it has been compiled."
(compile-file-interactively (current-buffer) nil))
(compile-file-interactively (current-view) nil))
(define-command (com-goto-location :name t :command-table climacs-lisp-table)
((note 'compiler-note))
......@@ -131,7 +131,7 @@ Definition command was issued."
()
"Compile and load definition at point."
(evaluating-interactively
(compile-definition-interactively (point) (current-syntax))))
(compile-definition-interactively (current-view) (point))))
(esa:set-key 'com-eval-defun
'climacs-lisp-table
......
This diff is collapsed.
......@@ -34,18 +34,18 @@
:components
((:file "packages")
(:file "text-syntax" :depends-on ("packages"))
(:file "cl-syntax" :depends-on ("packages"))
(:file "html-syntax" :depends-on ("packages"))
(:file "prolog-syntax" :depends-on ("packages"))
(:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
(:file "ttcn3-syntax" :depends-on ("packages"))
;; (:file "cl-syntax" :depends-on ("packages"))
;; (:file "html-syntax" :depends-on ("packages"))
;; (:file "prolog-syntax" :depends-on ("packages"))
;; (:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
;; (:file "ttcn3-syntax" :depends-on ("packages"))
(:file "climacs-lisp-syntax" :depends-on ("core" "groups"))
(:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
(:file "c-syntax" :depends-on ("core"))
(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands"))
(:file "java-syntax" :depends-on ("core"))
(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands"))
(:file "gui" :depends-on ("packages" "text-syntax"))
(:file "gui" :depends-on ("packages"))
(:file "core" :depends-on ("gui"))
(:file "io" :depends-on ("packages" "gui"))
(:file "groups" :depends-on ("core"))
......@@ -53,11 +53,12 @@
(:file "developer-commands" :depends-on ("core"))
(:file "file-commands" :depends-on ("gui" "core" "io"))
(:file "misc-commands" :depends-on ("gui" "core" #+nil "groups"))
(:file "search-commands" :depends-on ("gui" "core" #+nil "groups"))
(:file "misc-commands" :depends-on ("gui" "core" "groups"))
(:file "search-commands" :depends-on ("gui" "core" "groups"))
(:file "window-commands" :depends-on ("gui" "core"))
(:file "slidemacs" :depends-on ("packages" ))
(:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))))
;; (:file "slidemacs" :depends-on ("packages" ))
;; (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))
))
#+asdf
(defmethod asdf:perform :around ((o asdf:compile-op)
......
This diff is collapsed.
......@@ -136,27 +136,30 @@ Signals and error if the file does not exist."
;;;
;;; Buffer commands
(define-command (com-switch-to-buffer :name t :command-table pane-table)
((buffer 'buffer :default (or (second (buffers *application-frame*))
(any-buffer))))
(define-command (com-switch-to-view :name t :command-table pane-table)
((view 'view :default (or (second (views *application-frame*))
(any-view))))
"Prompt for a buffer name and switch to that buffer.
If the a buffer with that name does not exist, create it. Uses
the name of the next buffer (if any) as a default."
(switch-to-buffer (current-window) buffer))
(handler-case (switch-to-view (current-window) view)
(view-already-displayed (condition)
(other-window (window condition)))))
(set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*)
(set-key `(com-switch-to-view ,*unsupplied-argument-marker*)
'pane-table
'((#\x :control) (#\b)))
(define-command (com-kill-buffer :name t :command-table pane-table)
((buffer 'buffer
:prompt "Kill buffer"
:default (current-buffer)))
"Prompt for a buffer name and kill that buffer.
If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
(kill-buffer buffer))
(define-command (com-kill-view :name t :command-table pane-table)
((view 'view :prompt "Kill view"
:default (current-view)))
"Prompt for a view name and kill that view.
If the view is of a buffer and the buffer needs saving, you will
be prompted to do so before killing it. Uses the current view
as a default."
(kill-view view))
(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
(set-key `(com-kill-view ,*unsupplied-argument-marker*)
'pane-table
'((#\x :control) (#\k)))
......
This diff is collapsed.
This diff is collapsed.
......@@ -58,26 +58,18 @@
()
"Fill paragraph at point. Will have no effect unless there is a
string at point."
(let* ((pane (current-window))
(buffer (buffer pane))
(implementation (implementation buffer))
(syntax (syntax buffer))
(token (form-around syntax (offset (point pane))))
(fill-column (auto-fill-column pane))
(tab-width (tab-space-count (stream-default-view pane))))
(let* ((token (form-around (current-syntax) (offset (point))))
(fill-column (auto-fill-column (current-view))))
(when (typep token 'string-form)
(with-accessors ((offset1 start-offset)
(with-accessors ((offset1 start-offset)
(offset2 end-offset)) token
(fill-region (make-instance 'standard-right-sticky-mark
:buffer implementation
:offset offset1)
(make-instance 'standard-right-sticky-mark
:buffer implementation
:offset offset2)
(fill-region (make-buffer-mark (current-buffer) offset1 :right)
(make-buffer-mark (current-buffer) offset2 :right)
#'(lambda (mark)
(syntax-line-indentation mark tab-width syntax))
(syntax-line-indentation
mark (tab-space-count (current-view)) syntax))
fill-column
tab-width
(tab-space-count (current-view))
syntax
t)))))
......
This diff is collapsed.
......@@ -33,7 +33,7 @@
The modified flag is automatically set when the contents
of the buffer are changed. This flag is consulted, for instance,
when deciding whether to prompt you to save the buffer before killing it."
(setf (needs-saving (buffer (current-window))) nil))
(setf (needs-saving (current-buffer)) nil))
(set-key 'com-not-modified
'buffer-table
......@@ -75,7 +75,7 @@ FIXME: gives no information at end of buffer."
:prompt "Name of syntax"))
"Prompts for a syntax to set for the current buffer.
Setting a syntax will cause the buffer to be reparsed using the new syntax."
(set-syntax (current-buffer) syntax))
(set-syntax (current-view) syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......@@ -83,10 +83,10 @@ FIXME: gives no information at end of buffer."
(define-command (com-define-group :name t :command-table global-climacs-table)
((name 'string :prompt "Name")
(buffers '(sequence drei-buffer) :prompt "Buffers"))
(views '(sequence view) :prompt "Views"))
(when (or (not (get-group name))
(accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
(add-group name buffers))
(add-group name views))
(select-group (get-group name)))
(set-key `(com-define-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
......
......@@ -40,13 +40,24 @@
#:climacs-info-pane
#:typeout-pane
#:kill-ring
;; View-stuff
#:views
#:view-setting-error #:view
#:unknown-view
#:view-already-displayed #:window
#:remove-other-use #:remove-other-pane #:clone-view #:cancel
#:any-view #:any-undisplayed-view
#:clone-view-for-climacs
#:make-new-view-for-climacs
;; GUI functions follow.
#:any-buffer
#:point
#:syntax
#:mark
#:buffers
#:active-group
#:groups
#:display-window
......@@ -55,6 +66,7 @@
#:delete-window
#:other-window
#:buffer-pane-p
;; Some configuration variables
#:*bg-color*
......@@ -85,11 +97,11 @@
#:no-upper-p
#:case-relevant-test
#:switch-to-buffer
#:switch-to-view
#:make-new-buffer
#:make-new-named-buffer
#:erase-buffer
#:kill-buffer
#:kill-view
#:filepath-filename
#:update-attribute-line
......@@ -113,11 +125,11 @@
#:get-group
#:get-active-group
#:deselect-group
#:with-group-buffers
#:with-group-views
#:define-group
#:group-not-found
#:group-buffers
#:ensure-group-buffers
#:group-views
#:ensure-group-views
#:select-group
#:display-group-contents)
(:documentation "Package for editor functionality that is
......@@ -127,7 +139,7 @@
application, but are not solely GUI-specific."))
(defpackage :climacs-commands
(:use :clim-lisp :clim :drei-base :drei-buffer
(:use :clim-lisp :clim :esa-utils :drei-base :drei-buffer
:drei-syntax :drei-motion :drei-editing
:climacs-gui :esa :drei-kill-ring :drei
:drei-abbrev :drei-undo :climacs-core :drei-core)
......
......@@ -58,12 +58,13 @@ Entering an empty search string stops the prompting."
(multiple-query-replace strings)))
(define-command (com-multiple-query-replace-from-buffer :name t :command-table search-table)
((buffer 'buffer :prompt "Buffer with Query Repace strings"))
(unless (member buffer (buffers *application-frame*))
((view 'view :prompt "View with Query Repace strings"))
(unless (member view (views *esa-instance*))
(beep)
(display-message "~A not an existing buffer" (name buffer))
(display-message "~A not an existing buffer" (name view))
(return-from com-multiple-query-replace-from-buffer nil))
(let* ((contents (buffer-substring buffer 0 (1- (size buffer))))
(let* ((buffer (buffer view))
(contents (buffer-substring buffer 0 (1- (size buffer))))
(strings (loop with length = (length contents)
with index = 0
with start = 0
......@@ -102,22 +103,21 @@ Entering an empty search string stops the prompting."
(re (format nil "~{~A~^|~}" search-strings)))
(declare (special occurrences re))
(when strings
(let* ((pane (current-window))
(point (point pane))
(let* ((point (point))
(found (multiple-query-replace-find-next-match point re search-strings)))
(when found
(setf (query-replace-state pane)
(setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=)))
(query-replace-mode pane)
:string1 found
:string2 (cdr (assoc found strings :test #'string=)))
(query-replace-mode (current-window))
t)
(display-message "Replace ~A with ~A: "
(string1 (query-replace-state pane))
(string2 (query-replace-state pane)))
(string1 (query-replace-state (current-window)))
(string2 (query-replace-state (current-window))))
(simple-command-loop 'multiple-query-replace-drei-table
(query-replace-mode pane)
((setf (query-replace-mode pane) nil))))))
(query-replace-mode (current-window))
((setf (query-replace-mode (current-window)) nil))))))
(display-message "Replaced ~D occurrence~:P" occurrences)))
(define-command (com-multiple-query-replace-replace
......@@ -125,9 +125,8 @@ Entering an empty search string stops the prompting."
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences re))
(let* ((pane (current-window))
(point (point pane))
(state (query-replace-state pane))
(let* ((point (point (current-view)))
(state (query-replace-state (current-window)))
(string1 (string1 state))
(string1-length (length string1)))
(backward-object point string1-length)
......@@ -137,14 +136,14 @@ Entering an empty search string stops the prompting."
point
re
(mapcar #'car strings))))
(cond ((null found) (setf (query-replace-mode pane) nil))
(t (setf (query-replace-state pane)
(cond ((null found) (setf (query-replace-mode (current-window)) nil))
(t (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
(display-message "Replace ~A with ~A: "
(string1 (query-replace-state pane))
(string2 (query-replace-state pane))))))))
(string1 (query-replace-state (current-window)))
(string2 (query-replace-state (current-window)))))))))
(define-command (com-multiple-query-replace-replace-and-quit
......@@ -152,25 +151,23 @@ Entering an empty search string stops the prompting."
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences))
(let* ((pane (current-window))
(point (point pane))
(state (query-replace-state pane))
(let* ((point (point))
(state (query-replace-state (current-window)))
(string1 (string1 state))
(string1-length (length string1)))
(backward-object point string1-length)
(replace-one-string point string1-length (string2 state) (no-upper-p string1))
(incf occurrences)
(setf (query-replace-mode pane) nil)))
(setf (query-replace-mode (current-window)) nil)))
(define-command (com-multiple-query-replace-replace-all
:name t
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences re))
(let* ((pane (current-window))
(point (point pane))
(let* ((point (point))
(found nil))
(loop for state = (query-replace-state pane)
(loop for state = (query-replace-state (current-window))
for string1 = (string1 state)
for string1-length = (length string1)
do (backward-object point string1-length)
......@@ -184,31 +181,30 @@ Entering an empty search string stops the prompting."
re
(mapcar #'car strings)))
while found
do (setf (query-replace-state pane)
do (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
finally (setf (query-replace-state pane) nil))))
finally (setf (query-replace-state (current-window)) nil))))
(define-command (com-multiple-query-replace-skip
:name t
:command-table multiple-query-replace-drei-table)
()
(declare (special strings re))
(let* ((pane (current-window))
(point (point pane))
(let* ((point (point))
(found (multiple-query-replace-find-next-match
point
re
(mapcar #'car strings))))
(cond ((null found) (setf (query-replace-mode pane) nil))
(t (setf (query-replace-state pane)
(cond ((null found) (setf (query-replace-mode (current-window)) nil))
(t (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
(display-message "Replace ~A with ~A: "
(string1 (query-replace-state pane))
(string2 (query-replace-state pane)))))))
(string1 (query-replace-state (current-window)))
(string2 (query-replace-state (current-window))))))))
(defun multiple-query-replace-set-key (gesture command)
(add-command-to-command-table command 'multiple-query-replace-drei-table
......
......@@ -52,7 +52,7 @@
;;; Right stickies at non whitespace characters preceeded by space and punctuation.
;;;
(in-package :climacs-text-syntax) ;;; Put this in a separate package once it works
(in-package :climacs-text-syntax)
(defun index-of-mark-after-offset (flexichain offset)
"Searches for the mark after `offset' in the marks stored in `flexichain'."
......@@ -72,9 +72,14 @@
(:name "Text")
(:pathname-types "text" "txt" "README"))
(defmethod update-syntax (buffer (syntax text-syntax))
(let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
(low-offset (max (- (offset (low-mark buffer)) 3) 0)))
(defmethod update-syntax ((syntax text-syntax) prefix-size suffix-size
&optional begin end)
(declare (ignore begin end))
(let* ((buffer (buffer syntax))
(high-mark-offset (- (size buffer) suffix-size))
(low-mark-offset prefix-size)
(high-offset (min (+ high-mark-offset 3) (size buffer)))
(low-offset (max (- low-mark-offset 3) 0)))
(with-slots (paragraphs sentence-beginnings sentence-endings) syntax
(let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
(pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))
......@@ -106,7 +111,7 @@
(and (member current-object '(#\Newline #\Space #\Tab))
(or (= offset 1)
(not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
(let ((m (clone-mark (low-mark buffer) :left)))
(let ((m (make-buffer-mark buffer low-mark-offset :left)))
(setf (offset m) offset)
(insert* sentence-endings pos-sentence-endings m))
(incf pos-sentence-endings))
......@@ -117,7 +122,7 @@
(member prev-object '(#\Newline #\Space #\Tab)))
(or (<= offset 1)
(member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
(let ((m (clone-mark (low-mark buffer) :right)))
(let ((m (make-buffer-mark buffer low-mark-offset :right)))
(setf (offset m) offset)
(insert* sentence-beginnings pos-sentence-beginnings m))
(incf pos-sentence-beginnings))
......@@ -131,7 +136,7 @@
(and (eql prev-object #\Newline)
(or (= offset 1)
(eql before-prev-object #\Newline)))))
(let ((m (clone-mark (low-mark buffer) :left)))
(let ((m (make-buffer-mark buffer low-mark-offset :left)))
(setf (offset m) offset)
(insert* paragraphs pos1 m))
(incf pos1))
......@@ -142,7 +147,7 @@
(and (eql current-object #\Newline)
(or (= offset (1- buffer-size))
(eql next-object #\Newline)))))
(let ((m (clone-mark (low-mark buffer) :right)))
(let ((m (make-buffer-mark buffer low-mark-offset :right)))
(setf (offset m) offset)
(insert* paragraphs pos1 m))
(incf pos1))
......
......@@ -32,17 +32,33 @@
;;;
;;; Commands for splitting windows
(define-command (com-split-window-vertically :name t :command-table window-table) ()
(split-window t))
(set-key 'com-split-window-vertically
(defun split-window-maybe-cloning (vertically-p clone-current-view-p)
"Split `(current-window)', vertically if `vertically-p' is true,
horizontally otherwise. If `clone-current-view-p' is true, use a
clone of `(current-view)' for the new window."
(handler-bind ((view-already-displayed
#'(lambda (condition)
(declare (ignore condition))
;; If this happens, `clone-current-view-p' is false.
(display-message "Can't split: no view available for new window")
(return-from split-window-maybe-cloning nil))))
(split-window vertically-p clone-current-view-p)))
(define-command (com-split-window-vertically :name t
:command-table window-table)
((clone-current-view 'boolean :default nil))
(split-window-maybe-cloning t clone-current-view))
(set-key `(com-split-window-vertically ,*numeric-argument-p*)
'window-table
'((#\x :control) (#\2)))
(define-command (com-split-window-horizontally :name t :command-table window-table) ()
(split-window))
(define-command (com-split-window-horizontally :name t
:command-table window-table)
((clone-current-view 'boolean :default nil))
(split-window-maybe-cloning nil clone-current-view))
(set-key 'com-split-window-horizontally
(set-key `(com-split-window-horizontally ,*numeric-argument-p*)
'window-table
'((#\x :control) (#\3)))
......@@ -54,28 +70,28 @@
'((#\x :control) (#\o)))
(defun click-to-offset (window x y)
(with-slots (top bot) window
(let ((new-x (floor x (stream-character-width window #\m)))
(new-y (floor y (stream-line-height window)))
(buffer (buffer window)))
(loop for scan from (offset top)
with lines = 0
until (= scan (offset bot))
until (= lines new-y)
when (eql (buffer-object buffer scan) #\Newline)
do (incf lines)
finally (loop for columns from 0
until (= scan (offset bot))
until (eql (buffer-object buffer scan) #\Newline)
until (= columns new-x)
do (incf scan))
(return scan)))))
(with-accessors ((top top) (bot bot)) (view window)
(let ((new-x (floor x (stream-character-width window #\m)))
(new-y (floor y (stream-line-height window)))
(buffer (buffer (view window))))
(loop for scan from (offset top)
with lines = 0
until (= scan (offset bot))
until (= lines new-y)
when (eql (buffer-object buffer scan) #\Newline)
do (incf lines)
finally (loop for columns from 0
until (= scan (offset bot))
until (eql (buffer-object buffer scan) #\Newline)
until (= columns new-x)
do (incf scan))
(return scan)))))
(define-command (com-switch-to-this-window :name nil :command-table window-table)
((window 'pane) (x 'integer) (y 'integer))
(other-window window)
(when (buffer-pane-p window)
(setf (offset (point window))
(setf (offset (point (view window)))
(click-to-offset window x y))))
(define-presentation-to-command-translator blank-area-to-switch-to-this-window
......@@ -136,7 +152,7 @@
(define-command (com-scroll-other-window :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(page-down other-window))))
(page-down (view other-window)))))
(set-key 'com-scroll-other-window
'window-table
......@@ -145,7 +161,7 @@
(define-command (com-scroll-other-window-up :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
(page-up other-window))))
(page-up (view other-window)))))
(set-key 'com-scroll-other-window-up
'window-table
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment