Index: /release/1.4/source/contrib/foy/list-definitions-cm/history-lists.lisp =================================================================== --- /release/1.4/source/contrib/foy/list-definitions-cm/history-lists.lisp (revision 13072) +++ /release/1.4/source/contrib/foy/list-definitions-cm/history-lists.lisp (revision 13073) @@ -471,12 +471,25 @@ ;;; ---------------------------------------------------------------------------- ;;; File History Interface: -;;; -(objc:defmethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) +;;; +;;; *** Instead of doing all this stuff need the equivalent of: +;;; *** (setf ccl::*default-editor-class* 'derived-hemlock-frame-class) +#-syntax-styling +(objc:defMethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) (let* ((path (cmenu:window-path w)) (name (when (and path (string-equal (pathname-type path) "lisp")) (concatenate 'string (pathname-name path) ".lisp")))) (when (and name path) - (maybe-add-history-entry *file-history-list* name path)) - (call-next-method))) + (maybe-add-history-entry *file-history-list* name path))) + (let ((become-key-function (find-symbol "BECOME-KEY-WINDOW" (find-package :sax)))) + (when become-key-function (funcall become-key-function w))) + (call-next-method)) + +#+syntax-styling +(defMethod become-key-window ((w gui::hemlock-frame)) + (let* ((path (cmenu:window-path w)) + (name (when (and path (string-equal (pathname-type path) "lisp")) + (concatenate 'string (pathname-name path) ".lisp")))) + (when (and name path) + (maybe-add-history-entry *file-history-list* name path)))) ;;; ---------------------------------------------------------------------------- Index: /release/1.4/source/contrib/foy/list-definitions/history-lists.lisp =================================================================== --- /release/1.4/source/contrib/foy/list-definitions/history-lists.lisp (revision 13072) +++ /release/1.4/source/contrib/foy/list-definitions/history-lists.lisp (revision 13073) @@ -476,12 +476,25 @@ ;;; ---------------------------------------------------------------------------- ;;; File History Interface: -;;; -(objc:defmethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) - (let* ((path (window-path w)) +;;; +;;; *** Instead of doing all this stuff need the equivalent of: +;;; *** (setf ccl::*default-editor-class* 'derived-hemlock-frame-class) +#-syntax-styling +(objc:defMethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) + (let* ((path (cmenu:window-path w)) (name (when (and path (string-equal (pathname-type path) "lisp")) (concatenate 'string (pathname-name path) ".lisp")))) (when (and name path) - (maybe-add-history-entry *file-history-list* name path)) - (call-next-method))) + (maybe-add-history-entry *file-history-list* name path))) + (let ((become-key-function (find-symbol "BECOME-KEY-WINDOW" (find-package :sax)))) + (when become-key-function (funcall become-key-function w))) + (call-next-method)) + +#+syntax-styling +(defMethod become-key-window ((w gui::hemlock-frame)) + (let* ((path (cmenu:window-path w)) + (name (when (and path (string-equal (pathname-type path) "lisp")) + (concatenate 'string (pathname-name path) ".lisp")))) + (when (and name path) + (maybe-add-history-entry *file-history-list* name path)))) ;;; ---------------------------------------------------------------------------- Index: /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-1.lisp =================================================================== --- /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-1.lisp (revision 13073) +++ /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-1.lisp (revision 13073) @@ -0,0 +1,1022 @@ +;;;-*- mode: lisp; package: (syntax-styling (cl ccl hemlock-internals)) -*- + +;;; **************************************************************************** +;;; +;;; syntax-styling-1.lisp +;;; +;;; copyright (c) 2009 Glen Foy +;;; (Permission is granted to Clozure Associates to distribute this file.) +;;; +;;; This software is offered "as is", without warranty of any kind. +;;; +;;; Mod history, most recent first: +;;; 10/18/9 first cut. +;;; +;;; **************************************************************************** + + +(in-package "SAX") + +;;; *** redefinition *** +(let ((text-view nil) + (text-view-vscroll -100000)) + (defMethod gui::compute-temporary-attributes ((self gui::hemlock-textstorage-text-view)) + #+sax-debug (when *compute-temporary-attributes-debug* + (debug-out "~%~%~S" 'compute-temporary-attributes) + (debug-out "~%*style-screen-p*: ~S" *style-screen-p*) + (debug-out "~%*style-top-level-form-p*: ~S" *style-top-level-form-p*) + (debug-out "~%*paste-p*: ~S" *paste-p*) + (debug-out "~%*paste-start*: ~S" *paste-start*) + (debug-out "~%*paste-end*: ~S" *paste-end*)) + (let ((current-vscroll (gui::text-view-vscroll self))) + (when (or (not (equal self text-view)) + (not (= current-vscroll text-view-vscroll))) + (when (and *styling-p* *style-screen-p* (not *paste-p*)) + (style-screen self))) + (setq text-view self) + (setq text-view-vscroll current-vscroll)) + (cond (*style-top-level-form-p* + (style-top-level-form self)) + (*paste-p* + (setq *paste-end* (sexpr-end *paste-start*)) + (yank-after (gui::hemlock-view self) *paste-start* *paste-end*))) + (let* ((container (#/textContainer self)) + (layout (#/layoutManager container))) + (when (eql #$YES (gui::text-view-paren-highlight-enabled self)) + (let* ((background #&NSBackgroundColorAttributeName) + (paren-highlight-left (gui::text-view-paren-highlight-left-pos self)) + (paren-highlight-right (gui::text-view-paren-highlight-right-pos self)) + (paren-highlight-color (gui::text-view-paren-highlight-color self)) + (attrs (#/dictionaryWithObject:forKey: ns:ns-dictionary + paren-highlight-color + background))) + (#/addTemporaryAttributes:forCharacterRange: + layout attrs (ns:make-ns-range paren-highlight-left 1)) + (#/addTemporaryAttributes:forCharacterRange: + layout attrs (ns:make-ns-range paren-highlight-right 1)))))) + + (defun reset-text-view () (setq text-view nil))) + +;;; *** Buffer-writable is broken +;;; *** Instead of doing all this stuff need the equivalent of: +;;; *** (setf ccl::*default-editor-class* 'derived-hemlock-frame-class) +#-list-definitions +(let ((writable-p t) + (lisp-file-p t) + (hemlock-frame nil)) + (objc:defMethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) + (unless (equal w hemlock-frame) + (let ((path (window-path w)) + (file-manager (#/defaultManager ns:ns-file-manager))) + (setq writable-p + (if path + (#/isWritableFileAtPath: file-manager (ccl::%make-nsstring path)) + t)) ; new files may not have a path yet. + (setq lisp-file-p + (if path + (string-equal (pathname-type path) "lisp") + t))) ; we assume a new file is a lisp file. + (setq hemlock-frame w)) + (let ((become-key-function (find-symbol "BECOME-KEY-WINDOW" (find-package :ldefs)))) + (when become-key-function (funcall become-key-function w))) + (call-next-method)) + (defun lisp-file-p () lisp-file-p) + (defun writable-p () writable-p)) + +#+list-definitions +(let ((writable-p t) + (lisp-file-p t) + (hemlock-frame nil)) + (defMethod become-key-window ((w gui::hemlock-frame)) + (unless (equal w hemlock-frame) + (let ((path (window-path w)) + (file-manager (#/defaultManager ns:ns-file-manager))) + (setq writable-p + (if path + (#/isWritableFileAtPath: file-manager (ccl::%make-nsstring path)) + t)) ; new files may not have a path yet. + (setq lisp-file-p + (if path + (string-equal (pathname-type path) "lisp") + t))) ; we assume a new file is a lisp file. + (setq hemlock-frame w))) + (defun lisp-file-p () lisp-file-p) + (defun writable-p () writable-p)) + +(defun style-screen (text-view &optional generic-start generic-end) + (when *styling-p* + #+sax-debug (when *style-screen-debug* + (debug-out "~%~%~S" 'style-screen) + (debug-out "~%*paste-start*: ~S" *paste-start*) + (debug-out "~%*paste-end*: ~S" *paste-end*)) + (let* ((container (#/textContainer text-view)) + (scrollview (#/enclosingScrollView text-view)) + (contentview (if (%null-ptr-p scrollview) text-view (#/contentView scrollview))) + (rect (#/bounds contentview)) + (layout (#/layoutManager container)) + (glyph-range (#/glyphRangeForBoundingRect:inTextContainer: + layout rect container)) + (char-range (#/characterRangeForGlyphRange:actualGlyphRange: + layout glyph-range +null-ptr+)) + (window (#/window scrollview)) + (hemlock-view (gui::hemlock-view text-view)) + (current-buffer (hi::hemlock-view-buffer hemlock-view)) + (*buf* current-buffer) + (hi::*current-buffer* *buf*) + (*inc-pos* (clone (buffer-point *buf*))) + (*layout* (#/layoutManager container)) + top-pos bot-pos start-mark end-mark) + (unless (typep (#/window scrollview) 'gui::hemlock-listener-frame) + (setq top-pos (ns:ns-range-location char-range)) + (setq bot-pos (+ top-pos (ns:ns-range-length char-range))) + (setq start-mark (hemlock::top-level-offset (mark-offset (buf-start-mark current-buffer) top-pos) -1)) + (setq end-mark (hemlock::top-level-offset (mark-offset (buf-start-mark current-buffer) bot-pos) 1)) + (when (null start-mark) (setq start-mark (buf-start-mark))) + (when (null end-mark) (setq end-mark (buf-end-mark))) + (when (and start-mark end-mark) + (hemlock::parse-over-block (hemlock-internals::mark-line start-mark) + (hemlock-internals::mark-line end-mark)) + (if (and generic-start generic-end) + (set-generic-text-style text-view generic-start generic-end) + (set-generic-text-style text-view start-mark end-mark)) + (style-comments start-mark end-mark) + (style-forms window :start start-mark :end end-mark :caps-p nil :toplevel-p t)))))) + +(defParameter *defstyle-hash-table* (make-hash-table :test 'equal)) + +(defun get-function (name) + (gethash (string-upcase name) *defstyle-hash-table*)) + +(defun add-style (name-string func) + (setf (gethash (string-upcase name-string) *defstyle-hash-table*) func)) + +(defun style-elements (symbol-start form-end &optional loop-p) + "Step through the code sexpr by sexpr, styling appropriately." + #+sax-debug (when *style-elements-debug* + (debug-out "~%~%~S" 'style-elements) + (debug-out "~%element symbol-start: ~S" symbol-start) + (debug-out "~%element form-end: ~S" form-end)) + (flet ((not-char-constant-p (element-start) + (or (< (mark-charpos element-start) 2) + (char/= (mark-char element-start -1) #\\) + (char/= (mark-char element-start -2) #\#))) + (check-dynamic-p (element-start element-end) + (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* element-start) + (mark<= *inc-pos* element-end)))) + (loop-keywd-p (string) + ;; hash table? + (member string + '("above" "across" "always" "and" "append" "appending" "by" "collect" "collecting" "count" + "counting" "do" "doing" "downfrom" "downto" "each" "else" "end" "external-symbol" + "external-symbols" "finally" "for" "from" "hash-key" "hash-keys" "hash-value" + "hash-values" "if" "in" "into" "initially" "loop-finish" "maximize maximizing" + "minimize" "minimizing" "named" "nconc" "nconcing" "never" "of" "on" "present-symbol" + "present-symbols" "repeat" "return" "sum" "summing" "symbol" "symbols" "the" "then" + "thereis" "to" "unless" "until" "upfrom" "upto" "using" "when" "while" "with") + :test #'string-equal))) + (do* ((element-start symbol-start + (when element-end (next-sexpr-start element-end))) + (element-end (when element-start (sexpr-end element-start)) + (when element-start (sexpr-end element-start))) + (current-char (when element-start (mark-char element-start)) + (when element-start (mark-char element-start)))) + ((or (null element-start) (null element-end) (mark>= element-start form-end))) + #+sax-debug (when *style-elements-debug* + (debug-out "~%element-start: ~S" element-start) + (debug-out "~%element-end: ~S" element-end)) + (when (or (not *segment-array*) + (not-embedded-in-segment-p *segment-array* element-start)) + (when (or (char= current-char #\') + (char= current-char #\`) + (char= current-char #\,)) + (nmark-next element-start) + (setf current-char (mark-char element-start))) + (when (char= current-char #\@) + (nmark-next element-start) + (setf current-char (mark-char element-start))) + (when (char= current-char #\') + (nmark-next element-start) + (setf current-char (mark-char element-start))) + (when (char= current-char #\,) + (nmark-next element-start) + (setf current-char (mark-char element-start))) + (cond ((and (char= current-char #\() + (not-char-constant-p element-start) + (check-dynamic-p element-start element-end)) + (rd-style-forms :start element-start :end element-end)) + ((and (char= current-char #\#) + (mark< element-start (mark-offset (buf-end-mark) -2)) + (char= (mark-char element-start 1) #\') + (char= (mark-char element-start 2) #\() + (check-dynamic-p element-start element-end)) + (rd-style-forms :start (mark-offset element-start 2) :end element-end)) + ((and (char= current-char #\:) + (not-char-constant-p element-start)) + (style-region *keyword-package-style* + element-start (sexpr-end element-start))) + ((and loop-p + (alpha-char-p current-char) + (loop-keywd-p (region-to-string (region element-start element-end)))) + (style-region *loop-keyword-style* + element-start element-end))))))) + +(defun backward-top-level-list (start) + "Get the previous #\( in charpos 0, that is not embedded in a comment." + #+sax-debug (when *backward-top-level-list-debug* + (debug-out "~%~%~S" 'backward-top-level-list) + (debug-out "~%start: ~S" start)) + (when (null start) (return-from backward-top-level-list nil)) + (do* ((next (pattern-search start *l-paren-backward-pattern*) + (pattern-search (mark-prev next) *l-paren-backward-pattern*)) + not-embedded) + ((null next) (return nil)) + #+sax-debug (when *backward-top-level-list-debug* + (debug-out "~%next: ~S" next)) + (if *segment-array* + (setf not-embedded (not-embedded-in-segment-p *segment-array* next)) + (setf not-embedded t)) + #+sax-debug (when *backward-top-level-list-debug* + (debug-out "~%*segment-array*: ~S" *segment-array*) + (debug-out "~%not-embedded: ~S" not-embedded)) + (when (and (= (mark-charpos next) 0) not-embedded) + (return next)))) + +(defun forward-top-level-list (start &optional (end (buf-end-mark))) + "Get the next #\( in charpos 0, that is not embedded in a comment." + #+sax-debug (when *forward-top-level-list-debug* + (debug-out "~%~%~S" 'forward-top-level-list) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end)) + (when (or (null start) (null end)) (return-from forward-top-level-list nil)) + (do* ((next (pattern-search start *l-paren-forward-pattern* end) + (pattern-search (mark-next next) *l-paren-forward-pattern* end)) + not-embedded) + ((null next) (return nil)) + #+sax-debug (when *forward-top-level-list-debug* + (debug-out "~%next: ~S" next)) + (if *segment-array* + (setf not-embedded (not-embedded-in-segment-p *segment-array* next)) + (setf not-embedded t)) + #+sax-debug (when *forward-top-level-list-debug* + (debug-out "~%*segment-array*: ~S" *segment-array*) + (debug-out "~%not-embedded: ~S" not-embedded)) + (when (and (= (mark-charpos next) 0) not-embedded) + (return next)))) + +;;; This will skip incomplete forms and continue with the next toplevel list. +(defun list-top-level-forms (&optional (start (buf-start-mark)) (end (buf-end-mark))) + "Returns a list of starting marks for all the top-level lists in the range START, END." + #+sax-debug (when *list-top-level-forms-debug* + (debug-out "~%~%~S" 'list-top-level-forms) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end)) + (do* ((positions nil) + (sexpr-start (forward-top-level-list start end) + (when sexpr-end (forward-top-level-list sexpr-end end))) + (sexpr-end (when sexpr-start (limited-sexpr-end sexpr-start end)) + (when sexpr-start (limited-sexpr-end sexpr-start end)))) + ((or (null sexpr-start) + (mark> sexpr-start end)) + (return (nreverse positions))) + (cond (sexpr-end ; ie a complete list + (push sexpr-start positions)) + (t ; an incomplete list - skip it + (setq sexpr-end (mark-next sexpr-start)))))) + +(defun forward-list (start &optional (end (buf-end-mark))) + "Get the next #\( that is not embedded in a comment and not a character constant." + #+sax-debug (when *forward-list-debug* + (debug-out "~%~%~S" 'forward-list) + (debug-out "~%forward-list start: ~S" start) + (debug-out "~%forward-list end: ~S" end)) + (when (or (null start) (null end)) (return-from forward-list nil)) + (do* ((next (pattern-search start *l-paren-forward-pattern* end) + (pattern-search (mark-next next) *l-paren-forward-pattern* end)) + not-embedded) + ((null next) (return nil)) + #+sax-debug (when *forward-list-debug* + (debug-out "~%next: ~S" next)) + (if *segment-array* + (setf not-embedded (not-embedded-in-segment-p *segment-array* next)) + (setf not-embedded t)) + #+sax-debug (when *forward-list-debug* + (debug-out "~%*segment-array*: ~S" *segment-array*) + (debug-out "~%not-embedded: ~S" not-embedded)) + (cond ((>= (mark-charpos next) 2) + #+sax-debug (when *forward-list-debug* + (debug-out "~%(>= (mark-charpos next) 2)")) + (when (and not-embedded + (not (and (eq (mark-char next -1) #\\) + (eq (mark-char next -2) #\#))) + (neq (mark-char next -1) #\#)) + #+sax-debug (when *forward-list-debug* + (debug-out "~%returning: ~S" next)) + (return next))) + (t + #+sax-debug (when *forward-list-debug* + (debug-out "~%(< (mark-charpos next) 2)")) + (when not-embedded + #+sax-debug (when *forward-list-debug* + (debug-out "~%returning: ~S" next)) + (return next)))))) + +(defun list-forms (&optional (start (buf-start-mark)) (end (buf-end-mark))) + "Returns a list of starting marks for all the lists in the range START, END." + #+sax-debug (when *list-forms-debug* + (debug-out "~%~%~S" 'list-forms) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end)) + (do* ((positions nil) + (sexpr-start (forward-list start end) + (forward-list sexpr-end end)) + (sexpr-end (when sexpr-start (limited-sexpr-end sexpr-start end)) + (when sexpr-start (limited-sexpr-end sexpr-start end))) + (current-char (when sexpr-start (mark-char sexpr-start)) + (when sexpr-start (mark-char sexpr-start)))) + ((or (null sexpr-end) + (null sexpr-start) + (mark> sexpr-start end)) + (return (nreverse positions))) + #+sax-debug (when *list-forms-debug* + (debug-out "~%sexpr-start: ~S" sexpr-start) + (debug-out "~%sexpr-end: ~S" sexpr-end) + (debug-out "~%*inc-pos*: ~S" *inc-pos*) + (debug-out "~%current-char: ~S" current-char)) + (when (or (char= current-char #\') + (char= current-char #\`) + (char= current-char #\,)) + (nmark-next sexpr-start) + (setf current-char (mark-char sexpr-start))) + (when (char= current-char #\@) + (nmark-next sexpr-start) + (setf current-char (mark-char sexpr-start))) + (when (char= current-char #\') + (nmark-next sexpr-start) + (setf current-char (mark-char sexpr-start))) + (when (char= current-char #\,) + (nmark-next sexpr-start) + (setf current-char (mark-char sexpr-start))) + ;; when styling incrementally, only include forms + ;; if *inc-pos* is inside the form. + (cond ((char= current-char #\() + (when (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* sexpr-start) + (mark<= *inc-pos* sexpr-end))) + #+sax-debug (when *list-forms-debug* + (debug-out "~%pushing: ~S" (region-to-string (region sexpr-start sexpr-end)))) + (push sexpr-start positions))) + ((char= current-char #\#) + (cond ((and (mark< sexpr-start (buf-end-mark)) + (char= (mark-char sexpr-start 1) #\') + (char= (mark-char sexpr-start 2) #\()) + (when (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* sexpr-start) + (mark<= *inc-pos* sexpr-end))) + (push (nmark-next (nmark-next sexpr-start)) positions)))))))) + +(defun defstyle-form-styled-p (position) + "If there is a defstyle form at POSITION, style it and return T. If not, return NIL." + (when position + #+sax-debug (when *defstyle-form-styled-p-debug* + (debug-out "~%~%~S" 'defstyle-form-styled-p) + (debug-out "~%defstyle position: ~S" position)) + (let* ((symbol-start (mark-next position)) ; skip paren + (symbol-end (sexpr-end symbol-start)) + (string (region-to-string (region symbol-start symbol-end))) + (styling-function (get-function string))) + (when styling-function + (funcall styling-function position) + t)))) + +(defun package-form-styled-p (position) + "If there is a :cl function at POSITION, style it and return T. If not, return NIL." + (when position + #+sax-debug (when *package-form-styled-p-debug* + (debug-out "~%~%~S" 'package-form-styled-p) + (debug-out "~%package position: ~S" position)) + (let* ((symbol-start (mark-next position)) + (symbol-end (sexpr-end symbol-start))) + (cond ((char= (mark-char position) #\:) + (style-region *keyword-package-style* symbol-start symbol-end) t) + ((find-symbol (string-upcase (region-to-string (region symbol-start symbol-end))) :cl) + (style-region *cl-package-style* symbol-start symbol-end) + #+sax-debug (when *package-form-styled-p-debug* (debug-out "~%package styled")) + t))))) + +(defun rd-style-forms (&key (start (buf-start-mark)) (end (buf-end-mark)) top-level-p) + "Style the buffer using a recursive descent algorithm, given the range START, END." + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%~%~S" 'rd-style-forms) + (debug-out "~%rd-style-forms start: ~S" start) + (debug-out "~%rd-style-forms end: ~S" end)) + (let ((positions (if top-level-p (list-top-level-forms start end) (list-forms start end))) + form-end) + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%rd-style-forms positions: ~S" positions)) + (cond (positions + (dolist (position positions) + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%all positions: ~S" positions) + (debug-out "~%rd position list position: ~S" position)) + (unless (defstyle-form-styled-p position) + (when (setf form-end (limited-sexpr-end position end)) + (cond ((package-form-styled-p position) + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%rd position after package style: ~S" position)) + (let* ((next (nmark-next position)) + (end (sexpr-end next)) + (next-start (next-sexpr-start end))) + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%next: ~S" next) + (debug-out "~%end: ~S" end) + (debug-out "~%next-start: ~S" next-start)) + (setf position next-start)) + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%rd position after next-sexpr: ~S" position))) + (t + (nmark-next position))) + (when position (style-elements position form-end)))))) + (t + #+sax-debug (when *rd-style-forms-debug* + (debug-out "~%No positions in rd positions list -- doing style-elements.")) + (style-elements (nmark-next start) end))))) + +(defMethod style-top-level-form ((text-view gui::hemlock-textstorage-text-view)) + #+sax-debug (when *style-top-level-form-debug* + (debug-out (format nil "~%~%~S" 'style-top-level-form))) + (setq *style-top-level-form-p* nil) + (let* ((hemlock-view (gui::hemlock-view text-view)) + (*buf* (hemlock-view-buffer hemlock-view)) + (hi::*current-buffer* *buf*) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*current-package* (hemlock::buffer-package *buf*)) + (*style-case-p* (if (null *style-case-p*) nil (writable-p)))) + (cond ((not (buffer-empty-p)) + (let* ((start (backward-top-level-list (clone (buffer-point *buf*)))) + (end (when start (clone start)))) + (when (and end (hemlock::form-offset end 1)) + #+sax-debug (when *style-top-level-form-debug* + (debug-out (format nil "~%start: ~S" start)) + (debug-out (format nil "~%end: ~S" end))) + (hemlock::parse-over-block (mark-line start) (mark-line end)) + (set-generic-text-style text-view start end) + (rd-style-forms :start start :end end :top-level-p t)))) + (t + (ed-beep))))) + +(defMethod style-forms ((hemlock-view hi::hemlock-view) &key (caps-p t) start end toplevel-p) + (let* ((text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))) + (*buf* (hemlock-view-buffer hemlock-view)) + (hi::*current-buffer* *buf*) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*current-package* (hemlock::buffer-package *buf*)) + (*style-case-p* (if (null caps-p) nil *style-case-p*))) + (cond ((not (buffer-empty-p)) + (unless (and start end) + (multiple-value-setq (start end) + (selection-marks text-view))) + (unless (and start end) + (setf start (buf-start-mark) end (buf-end-mark))) + (hemlock::parse-over-block (mark-line start) (mark-line end)) + (rd-style-forms :start start :end end :top-level-p toplevel-p)) + (t + (ed-beep))))) + +(defMethod style-forms ((window gui::hemlock-frame) &key (caps-p t) start end toplevel-p) + (style-forms (gui::hemlock-view window) :start start :end end :caps-p caps-p :toplevel-p toplevel-p)) + + +;;; ---------------------------------------------------------------------------- +;;; The batch styling interface: +;;; ---------------------------------------------------------------------------- +;;; +(defMethod style-window ((window gui::hemlock-frame)) + (if (writable-p) + (let* ((hemlock-view (gui::hemlock-view window)) + (text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))) + (*buf* (hemlock-view-buffer hemlock-view)) + (hi::*current-buffer* *buf*) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*current-package* (hemlock::buffer-package *buf*)) + ;; If a file is not writable, style with color and underlining, but not caps. + (*style-case-p* (if (null *style-case-p*) nil (writable-p)))) + (multiple-value-bind (start end) (selection-marks text-view) + (unless (and start end) + (setf start (buf-start-mark) end (buf-end-mark))) + (hemlock::parse-over-block (mark-line start) (mark-line end)) + (set-generic-text-style text-view start end) + (style-comments start end) + (style-forms window :start start :end end))) + (listener-msg "~%~S is not writable." (window-path window)))) + +(defun style-folder-recursively () + (let ((dir (gui::cocoa-choose-directory-dialog))) + (when dir + (cond ((pathnamep dir) + (listener-msg "~%~%~a files styled." + (style-folder (directory-namestring dir)))) + (t + (listener-msg "~%~%~a files styled." + (style-folder dir))))))) + +(defun style-folder (folder) + (let ((files (directory (merge-pathnames folder "*.lisp") :files t :directories nil)) + (folders (directory (merge-pathnames folder "*") :files nil :directories t)) + (file-count 0)) + (dolist (file files) + (listener-msg "~%;;; Styling: ~a" file) + (incf file-count) + (let* ((view (gui::cocoa-edit file)) + (window (#/window (hi::hemlock-view-pane view))) + (buffer (hemlock-view-buffer view)) + (document (hi::buffer-document buffer))) + (cond ((writable-p) + (style-window window) + (gui::save-hemlock-document document) + (#/close window)) + (t + (listener-msg "~%;;; File is read-only: ~S" file))))) + (dolist (folder folders) + (incf file-count (style-folder folder))) + file-count)) + +(defun vanilla-style (buffer start end) + ;; Set the font spec of the text to the default; but leave the capitalization + ;; of strings, comments and various constants alone. + (let ((buf-start (buf-start-mark buffer)) + (buf-end (buf-end-mark buffer)) + skip-list case) + (hemlock::parse-over-block (mark-line start) (mark-line end)) + (set-style-attributes (attribute-dictionary *vanilla-styling*) start end) + ;; *** this should use start and end + (setf skip-list (get-combined-segment-list)) + (setf case (style-case *vanilla-styling*)) + ;; (pprint skip-list) + (cond (skip-list + (do* ((segment (pop skip-list) (pop skip-list)) + (seg-start buf-start next-start) + (seg-end (first segment) (first segment)) + (next-start (second segment) (second segment))) + ((or (mark>= seg-start end) + (null seg-start) + (null seg-end))) + (when (and (mark>= seg-start start) + (mark<= seg-start end)) + (cond ((eql case :up) + (upcase-region seg-start (mark-min seg-end end))) + ((eql case :down) + (downcase-region seg-start (mark-min seg-end end))))))) + (t + (cond ((eql case :up) + (upcase-region buf-start buf-end)) + ((eql case :down) + (downcase-region buf-start buf-end))))))) + +(defMethod style-vanilla ((window gui::hemlock-frame)) + (let* ((hemlock-view (gui::hemlock-view window)) + (text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*buf* (hemlock-view-buffer hemlock-view)) + (hi::*current-buffer* *buf*)) + (cond ((writable-p) + (multiple-value-bind (start end) (selection-marks text-view) + (unless (and start end) + (setf start (buf-start-mark) end (buf-end-mark))) + (vanilla-style *buf* start end))) + (t + (listener-msg "~%;;; File is read-only: ~S" (window-path window)))))) + +;;; ---------------------------------------------------------------------------- +;;; The interface for the incremental algorithm: +;;; ---------------------------------------------------------------------------- +;;; +(defConstant %inserted-parens% 37) + +(defun dynamically-style-buffer (hemlock-view) + (let* ((*inc-p* t) + (*buf* (hemlock-view-buffer hemlock-view)) + (*form-style* nil) + (*form-start* nil) + (*form-end* nil) + (*superparen-closure* nil) + (*segment-array* nil) + (hi::*current-buffer* *buf*) + (text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view))) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*inc-pos* (clone (buffer-point *buf*))) + (comment-end (or (buffer-top-level-sexpr-end *buf*) (buf-end-mark))) + (atom-start (atom-start (mark-prev *inc-pos*))) ; *** ? + (atom-end (or (atom-end *inc-pos*) *inc-pos*)) + (char (mark-char (mark-max (buf-start-mark) (or (mark-prev *inc-pos*) *inc-pos*)))) + (*style-case-p* (if (null *style-case-p*) nil (writable-p))) + style-end) + (when char + #+sax-debug (when *dynamically-style-buffer-debug* + (debug-out "~%~%~S" 'dynamically-style-buffer) + (debug-out "~%*inc-pos*: ~S" *inc-pos*) + (debug-out "~%char: ~S" char) + (debug-out "~%atom-start: ~s" atom-start) + (debug-out "~%atom-end: ~s" atom-end)) + (cond ((and (char= char #\#) + (char= (mark-char (mark-max (buf-start-mark) (mark-offset *inc-pos* -2))) #\|)) + ;; *** could do better than buf-start-mark + (style-comments (buf-start-mark) comment-end)) + (t + (multiple-value-bind (start inside-quotes-p semi-colon-pos) + (calculate-context char) + #+sax-debug (when *dynamically-style-buffer-debug* + (debug-out "~%~%start: ~S" start) + (debug-out "~%inside-quotes-p: ~S" inside-quotes-p) + (debug-out "~%semi-colon-pos: ~S" semi-colon-pos)) + (unless start (setq start (buf-start-mark))) + (dynamically-style-comments start comment-end t t) + (when (or inside-quotes-p + (and (char= char #\") (not inside-quotes-p))) + #+sax-debug (when *dynamically-style-buffer-debug* + (debug-out "~%start: ~S" start) + (debug-out "~%comment-end: ~S" comment-end)) + (return-from dynamically-style-buffer (values atom-start atom-end))) + (cond (semi-colon-pos + (let ((line-end (line-end (clone semi-colon-pos)))) + (when line-end + ;; eliminate paren highlighting: + (let* ((begin (mark-absolute-position start)) + (count (- (mark-absolute-position line-end) begin))) + (when (and begin count) + (ns:with-ns-range (char-range begin count) + (let* ((layout (#/layoutManager text-view))) + (#/removeTemporaryAttribute:forCharacterRange: + layout #&NSBackgroundColorAttributeName + char-range))))) + (set-style-attributes (attribute-dictionary *semi-colon-comment-style*) + semi-colon-pos line-end)))) + (t + (unwind-protect + (progn + (#/beginEditing (#/textStorage text-view)) + (insert-string (copy-mark atom-end) " o ))))))))))))))))))))))))))))))))))") + (setf style-end (mark-offset (copy-mark atom-end) %inserted-parens%)) + (hemlock::parse-over-block (hi::mark-line start) (hi::mark-line style-end)) + (rd-style-forms :start start :end style-end) + (unless (or *form-style* *paste-p* (member char '(#\( #\) #\" #\space #\;))) + (when atom-start + (setq *form-style* *generic-text-style* + *form-start* atom-start + *form-end* atom-end)))) + (delete-characters atom-end %inserted-parens%) + (#/endEditing (#/textStorage text-view)) + (when *form-style* + (set-style-attributes (attribute-dictionary *form-style*) *form-start* *form-end*)) + (when *superparen-closure* + (funcall *superparen-closure*)) + ;; Setting attributes for a region leaves point at the end + ;; of the symbol. Move it back, unless editing there: + (let ((point (buffer-point *buf*))) + (when (not (mark= point *inc-pos*)) + (let ((offset (- (mark-charpos point) (mark-charpos *inc-pos*)))) + (dotimes (count offset) + ;; a less moronic way to do this?? + (hi::handle-hemlock-event hemlock-view %backward-char-event%))))))))))) + (values atom-start atom-end)))) + +(defun calculate-context (new-char) + "Calculate top-level-start-pos inside-quotes-p semi-colon-pos" + #+sax-debug (when *calculate-context-debug* + (debug-out "~%~%~S" 'calculate-context) + (debug-out "~%new-char: ~S" new-char) + (debug-out "~%*inc-pos*: ~S" *inc-pos*) + (debug-out "~%point: ~S" (buffer-point *buf*)) + (debug-out "~%(mark-char point): ~S" (mark-char (buffer-point *buf*)))) + (let* ((point (clone (buffer-point *buf*))) + (right-quote-pos (when (char= new-char #\") (clone point))) + top-level-start-pos inside-quotes-p semi-colon-pos left-quote-pos) + (flet ((return-even-quote-values () + (when (and right-quote-pos left-quote-pos semi-colon-pos) + ;; mark< is not trinary + (when (and (mark< left-quote-pos semi-colon-pos) + (mark< semi-colon-pos right-quote-pos)) + (setq semi-colon-pos nil))) + (return-from calculate-context + (values top-level-start-pos inside-quotes-p semi-colon-pos))) + (return-odd-quote-values () + (when (and semi-colon-pos left-quote-pos) + (cond ((mark< left-quote-pos semi-colon-pos) + (setq semi-colon-pos nil)) + (t + (setq inside-quotes-p nil)))) + (return-from calculate-context + (values top-level-start-pos inside-quotes-p semi-colon-pos)))) + (do* ((buf-start (buf-start-mark)) + (pos (or (mark-prev *inc-pos*) buf-start)) + (char (mark-char pos) (mark-char pos)) + (char-1 (mark-char (mark-max (or (mark-prev pos) pos) buf-start)) + (mark-char (mark-max (or (mark-prev pos) pos) buf-start))) + (first-char-p t nil) + (quote-count 0) + line-start-p) + ((and char char-1 (char= char #\() (or (char-eolp char-1) (mark= pos buf-start))) + (setq top-level-start-pos pos) + #+sax-debug (when *calculate-context-debug* + (debug-out "~%quote-count: ~S" quote-count)) + (cond ((= (mod quote-count 2) 0) ; even quotes + (setf inside-quotes-p nil) + (return-even-quote-values)) + (t + (setf inside-quotes-p t) + (return-odd-quote-values)))) + (cond ((null char) + (setq semi-colon-pos nil)) + ((and (char-eolp char) (not first-char-p)) + (setq line-start-p t)) + ((and (char= char #\;) (not line-start-p) (not (char= char-1 #\\))) + (setq semi-colon-pos pos)) + ((and (char= char #\") (not (char= char-1 #\\))) + (incf quote-count) + (unless right-quote-pos (setq right-quote-pos pos)) + (setq left-quote-pos pos))) + (setq pos (mark-prev pos)) + (when (null pos) + (setq top-level-start-pos nil) + (cond ((= (mod quote-count 2) 0) + (setq inside-quotes-p nil) + #+sax-debug (when *calculate-context-debug* + (debug-out "~%inside-quotes-p is nil")) + (return-even-quote-values)) + (t + (setq inside-quotes-p t) + #+sax-debug (when *calculate-context-debug* + (debug-out "~%inside-quotes-p: t")) + (return-odd-quote-values)))))))) + +;;; *** This need work: +(defun char-printable-p (char event) + "Is the char printable?" + (let ((code (char-code char))) + #+sax-debug (when *char-printable-p-debug* + (debug-out "~%~%~S" 'char-printable-p) + (debug-out "~%char: ~s" char) + ;; (hi::print-pretty-key-event (hi::char-key-event char) t t) + (debug-out "~%code: ~s" code)) + (let ((control-key-p (hi::key-event-bit-p event "Control")) + (option-key-p (hi::key-event-bit-p event "Meta"))) + #+sax-debug + (when *automated-testing-p* + (setq control-key-p nil + option-key-p nil)) + #+sax-debug (when *char-printable-p-debug* (debug-out "~%control-key-p: ~s" control-key-p)) + #+sax-debug (when *char-printable-p-debug* (debug-out "~%option-key-p: ~s" option-key-p)) + (cond ((not (or control-key-p option-key-p)) + (when (or (and (>= code 32) (<= code 127)) ; this is the primary case + ;; *** define constants + (= code 13) ; #\newline + (= code 8) ; #\delete, #\backspace + (= code 10) ; $\linefeed + (= code 127)) ; #\del + #+sax-debug (when *char-printable-p-debug* (debug-out "~%printable1")) + t)) + #+elvis + ((and control-key-p option-key-p) + #+sax-debug (when *char-printable-p-debug* (debug-out "~%printable2")) + (when (or (= code 8)) ; control-meta-h & control-meta-delete **** + t)) + (control-key-p + (when (or (= code 100) ; control-d + ;; (= code 4) ; *** ? + (= code 11) ; control-k + (= code 23)) ; control-w + #+sax-debug (when *char-printable-p-debug* (debug-out "~%printable3")) + t)) + (option-key-p + (when (or (= code 182) ; meta-d + (= code 202) ; meta-space ?? *** + (= code 199)) ; meta-\ ?? *** + #+sax-debug (when *char-printable-p-debug* (debug-out "~%printable4")) + t)) + (t nil))))) + +(defun restyle-comment (view) + #+sax-debug (when *handle-hemlock-event-debug* (debug-out "~%restyle-comment-p")) + (let* ((line-start (buffer-line-start *buf*)) + (line-end (buffer-line-end *buf*)) + (hi::*current-buffer* *buf*) + (*current-package* (hemlock::buffer-package *buf*)) + (text-view (gui::text-pane-text-view (hi::hemlock-view-pane view))) + (*layout* (#/layoutManager (#/textContainer text-view)))) + (when (and line-start line-end) + (style-region *generic-text-style* line-start line-end nil) + (style-comments line-start line-end) + (style-forms view :start line-start :end line-end)))) + +;;; *** redefinition *** +(defMethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event) + (let* ((*buf* (hemlock-view-buffer view)) + (hi::*current-buffer* *buf*) + (*inc-pos* nil) + (*paste-p* nil) + (*paste-start* nil) + (*paste-end* nil) + (keysym (when (typep event 'hi::key-event) + (hi::key-event-keysym event))) + (keysym-code (when keysym (hi::code-for-keysym keysym)))) + (cond ((and keysym *styling-p* (not (keywordp keysym)) ; char can be :end, :home, etc + (not (hi::buffer-minor-mode *buf* "I-Search"))) + (let ((char (code-char keysym-code))) + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%~%~S" 'handle-hemlock-event) + (debug-out "~%char: ~S" char)) + (when (key-event= event %control-y%) + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%*paste-start*: ~S" (clone (buffer-point *buf*)))) + (setq *paste-p* t) + (setq *paste-start* (clone (buffer-point *buf*)))) + (when (key-event= event %control-j%) + (setq *style-top-level-form-p* t)) + (if (and char (not (typep (#/window (hi::hemlock-view-pane view)) 'gui::hemlock-listener-frame)) + (char-printable-p char event) (lisp-file-p)) + (let* ((point (buffer-point *buf*)) + (point-char (mark-char point)) + (char-1 (mark-char (mark-max (or (mark-prev point) point) (buffer-start-mark *buf*)))) + (*style-screen-p* nil) + ;; If a file is not writable, style with color and underlining, but not caps. + (*style-case-p* (if (null *style-case-p*) nil (writable-p))) + restyle-comment-p) + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%point: ~S" point) + (debug-out "~%point-char: ~S" point-char) + (debug-out "~%char-1: ~S" char-1)) + (cond ((and (key-event= event %backspace%) ; backspace & delete + char-1 + (char= char-1 #\;)) + (setf restyle-comment-p t)) + ((and point-char (char= point-char #\;) + ;; (or (key-event= event %del%) ; #\del + (key-event= event %control-d%)) ; control-d + (setf restyle-comment-p t))) + + ;; insert the char: + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%~%inserting char: ~S" char)) + (ccl::with-autorelease-pool + (call-next-method view event)) + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%~%char inserted")) + + (cond (restyle-comment-p + (restyle-comment view)) + (t + (dynamically-style-buffer view)))) + (ccl::with-autorelease-pool + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%~%not styled -- calling next method.")) + (call-next-method view event) + (cond ((key-event= event %control-y%) + #+sax-debug (when *handle-hemlock-event-debug* + (debug-out "~%setting *paste-end*: ~S" (clone (buffer-point *buf*)))) + (setq *paste-end* (clone (buffer-point *buf*))))))))) + ; (yank-after view *paste-start* *paste-end*))))))) + ; ((key-event= event %control-meta-q%) + ; (indentation-after view))))))) + (t + (ccl::with-autorelease-pool + (call-next-method view event)))))) + +;;; Neither of these two are right. See the note below. +(objc:defMethod (#/paste: :void) ((text-view gui::hemlock-text-view) (sender :id)) + (reset-text-view) + (call-next-method sender)) + +(defMethod yank-after ((view hi::hemlock-view) generic-start generic-end) + (let ((text-view (gui::text-pane-text-view (hi::hemlock-view-pane view)))) + (hi::handle-hemlock-event view #'(lambda () (style-screen text-view generic-start generic-end))))) + +#| +;;; This is the right way to do paste and yank, but the text +;;; is being set back to plain by some disagreeable and as yet +;;; unidentified function. (Cocoa??) +(defMethod yank-after ((view hi::hemlock-view) generic-start generic-end) + (when (and *styling-p* (lisp-file-p) + (not (typep (#/window (hi::hemlock-view-pane view)) 'gui::hemlock-listener-frame))) + (let* ((text-view (gui::text-pane-text-view (hi::hemlock-view-pane view))) + (*buf* (hi::hemlock-view-buffer view)) + (hi::*current-buffer* *buf*) + (*layout* (#/layoutManager (#/textContainer text-view))) + (*current-package* (hemlock::buffer-package *buf*)) + (start (buffer-top-level-sexpr-start *buf*)) + (end (buffer-point *buf*)) + (*style-screen-p* nil) + ;; If a file is not writable, style with color and underlining, but not caps. + (*style-case-p* (if (null *style-case-p*) nil (writable-p)))) + #+sax-debug (when *yank-after-debug* + (debug-out "~%~%~S" 'yank-or-paste-after) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end) + (debug-out "~%*inc-pos*: ~S" *inc-pos*)) + ;; *paste-p*, *paste-start* and *paste-end* are set above. + (when (and start end) + (hemlock::parse-over-block (hemlock-internals::mark-line start) + (hemlock-internals::mark-line end)) + (set-generic-text-style text-view generic-start generic-end) + (dynamically-style-comments start end t t) + (dynamically-style-buffer view)) + (setq *paste-p* nil *paste-start* nil *paste-end* nil)))) + ;; (gui::update-paren-highlight text-view)))) +|# + +;;; ---------------------------------------------------------------------------- +;;; styling menu items +;;; ---------------------------------------------------------------------------- +;;; +(defParameter *edit-menu* + (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Edit"))) + +(objc:defMethod (#/toggleStylingAction: :void) ((item ns:ns-menu-item) (sender :id)) + (cond (*styling-p* + (setq *styling-p* nil) + (#/setState: sender #$NSOffState)) + (t + (setq *styling-p* t) + (#/setState: sender #$NSOnState)))) + +(let ((styling-item (#/itemWithTitle: *edit-menu* #@"Styling")) + item) + (unless (%null-ptr-p styling-item) (#/removeItem: *edit-menu* styling-item)) + (when (%null-ptr-p styling-item) + (#/addItem: *edit-menu* (#/separatorItem ns:ns-menu-item)) + (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc ns:ns-menu-item) + #@"Syntax Styling" + (ccl::@selector "toggleStylingAction:") + #@"")) + (#/setTarget: item item) + (#/setState: item #$NSOnState) + (#/addItem: *edit-menu* item))) + + + +(when *style-case-p* + +(defParameter *style-file-item* nil) +(defParameter *style-file-vanilla-item* nil) + +(defClass STYLING-MENU-ITEM (ns:ns-menu-item) + () + (:metaclass ns:+ns-object)) + +(objc:defMethod (#/styleFileAction: :void) ((item styling-menu-item) (sender :id)) + (declare (ignore sender)) + (let ((window (active-hemlock-window))) + (when window + (style-window window)))) + +(objc:defMethod (#/styleFileVanillaAction: :void) ((item styling-menu-item) (sender :id)) + (declare (ignore sender)) + (let ((window (active-hemlock-window))) + (when window + (style-vanilla window)))) + +(objc:defMethod (#/styleFolderAction: :void) ((item styling-menu-item) (sender :id)) + (declare (ignore sender)) + (style-folder-recursively)) + +(objc:defMethod (#/validateMenuItem: :) ((item styling-menu-item) item) + *styling-p*) + +(let ((style-file-item (#/itemWithTitle: *edit-menu* #@"Style File")) + item) + (when (%null-ptr-p style-file-item) + (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc styling-menu-item) + #@"Style File" + (ccl::@selector "styleFileAction:") + #@"u")) + (#/setTarget: item item) + (setq *style-file-item* item) + (#/addItem: *edit-menu* item))) + +(let ((style-file-vanilla-item (#/itemWithTitle: *edit-menu* #@"Style File Vanilla")) + item) + (when (%null-ptr-p style-file-vanilla-item) + (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc styling-menu-item) + #@"Style File Vanilla" + (ccl::@selector "styleFileVanillaAction:") + #@"U")) + (#/setTarget: item item) + (setq *style-file-vanilla-item* item) + (#/addItem: *edit-menu* item))) + +(let ((style-folder-item (#/itemWithTitle: *edit-menu* #@"Style Folder ...")) + item) + (when (%null-ptr-p style-folder-item) + (setf item (#/initWithTitle:action:keyEquivalent: (#/alloc styling-menu-item) + #@"Style Folder ..." + (ccl::@selector "styleFolderAction:") + #@"")) + (#/setTarget: item item) + (#/addItem: *edit-menu* item))) + +) ; closing paren for when + + + Index: /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-2.lisp =================================================================== --- /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-2.lisp (revision 13073) +++ /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-2.lisp (revision 13073) @@ -0,0 +1,757 @@ +;;;-*- Mode: Lisp; Package: (SYNTAX-STYLING (CL CCL HEMLOCK-INTERNALS)) -*- + +;;; **************************************************************************** +;;; +;;; syntax-styling-2.lisp +;;; +;;; copyright (c) 2009 Glen Foy +;;; (Permission is granted to Clozure Associates to distribute this file.) +;;; +;;; Macros and styling functions. +;;; +;;; This software is offered "as is", without warranty of any kind. +;;; +;;; Mod History, most recent first: +;;; 10/18/9 First cut. +;;; +;;; **************************************************************************** + +(in-package "SAX") + +;;; ---------------------------------------------------------------------------- +;;; Macros used to construct the styling functions below. +;;; ---------------------------------------------------------------------------- +;;; +;;; NOTE: Not bothering to gensym these macros. They are only used in this file, +;;; and the only variable capture is the intensional variable capture of POS. +;;; +(defMacro sparen (style debug-flag name) + (declare (ignorable debug-flag name)) + `(when pos + #+sax-debug (when (and debug-function-p ,debug-flag) + (debug-out "~%~%~S" ,name) + (debug-out "~%pos: ~S" pos)) + (let ((end (mark-next pos))) + #+sax-debug (when (and debug-function-p ,debug-flag) + (debug-out "~%end: ~S" end)) + (when end + (if *inc-p* + (when (mark< pos *inc-pos*) + (let* ((macro-start (next-sexpr-start end)) + (macro-end (sexpr-end macro-start))) + (when (or (mark= end *inc-pos*) + (and macro-end macro-start (alpha-char-p (mark-char macro-start)) + (mark= *inc-pos* macro-end) (mark= macro-start end))) + #+sax-debug (when (and debug-function-p ,debug-flag) + (debug-out "~%*inc-pos*: ~S" *inc-pos*) + (debug-out "~%macro-end: ~S" macro-end)) + (let ((start (clone pos))) + (setq *superparen-closure* + #'(lambda () + #+sax-debug (when (and debug-function-p ,debug-flag) + (debug-out "~%~%closure being called.")) + (set-style-attributes (attribute-dictionary ,style) + start end))))))) + (style-region ,style pos end nil)) + (setq pos (nnext-sexpr-start end)))))) + +(defMacro superparen () + "Super parens surround top-level forms and embedded function definitions." + `(sparen *superparen-style* *superparen-debug* 'superparen)) + +(defMacro eval-when-superparen () + "Eval-when deserves a distinctive style for its parens." + `(sparen *eval-when-superparen-style* *eval-when-superparen-debug* 'eval-when-superparen)) + +(defMacro loop-superparen () + "Loop deserves a distinctive style for its parens." + `(sparen *loop-superparen-style* *loop-superparen-debug* 'loop-superparen)) + +(defMacro paren () + "This does no styling; it just increments POS." + `(when pos #+sax-debug (when (and debug-function-p *paren-debug*) + (debug-out "~%~%~S" 'paren)) + (setq pos (nnext-sexpr-start (mark-next pos))))) + +(defMacro optional-paren () + "This does no styling; it just increments POS, if there is a paren." + `(when pos #+sax-debug (when (and debug-function-p *optional-paren-debug*) + (debug-out "~%~%~S" 'optional-paren)) + (let ((pos-char (mark-char pos))) + (when (or (char= pos-char #\() + (char= pos-char #\))) + (setq pos (nnext-sexpr-start (mark-next pos))))))) + +(defMacro objc-symbl (pos) + "Style an objc symbol, or list containing symbol and return value." + `(setq ,pos (objc-symbol-styling-function ,pos))) + +(defMacro symbl () + "Style a symbol-name, taking into account exported symbols." + `(when pos #+sax-debug (when (and debug-function-p *symbol-debug*) + (debug-out "~%~%~S" 'symbl) + (debug-out "~%symbol-style: ~S" symbol-style)) + (let ((pos-end (sexpr-end pos))) + (when pos-end + #+sax-debug (when (and debug-function-p *symbol-debug*) + (debug-out "~%pos-end: ~S" pos-end)) + (let ((name (string-upcase (region-to-string (region pos pos-end))))) + (when name + (multiple-value-bind (symbol kind) + (find-symbol name *current-package*) + (cond ((and symbol *current-package* (eq kind :external) + (not (eq symbol-style *variable-definition-symbol-style*))) + (cond ((char= (mark-char pos) #\") + ; a string, don't set caps + (style-region *exported-symbol-style* pos pos-end nil)) + (t + (style-region *exported-symbol-style* pos pos-end)))) + (t + (cond ((char= (mark-char pos) #\") + (style-region symbol-style pos pos-end nil)) + (t + (style-region symbol-style pos pos-end)))))))) + (setq pos (next-sexpr-start pos-end)))))) + +(defMacro struct-sym () + "Style the name of a structure." + `(when pos #+sax-debug (when (and debug-function-p *struct-sym-debug*) + (debug-out "~%~%~S" 'struct-sym)) + (setq pos (next-sexpr-start (struct-sym-styling-function pos))))) + +(defMacro struct-fields () + "Style structure fields." + `(when pos #+sax-debug (when (and debug-function-p *struct-fields-debug*) + (debug-out "~%~%~S" 'struct-fields)) + (do* ((field-start pos (next-sexpr-start field-end)) + (field-end (when field-start (sexpr-end field-start)) + (when field-start (sexpr-end field-start)))) + ((or (null field-start) (mark> field-start form-end))) + (cond ((char= (mark-char field-start) #\() + (let* ((symbol-start (mark-next field-start)) + (symbol-end (when symbol-start (sexpr-end symbol-start))) + (next-start (when symbol-end (next-sexpr-start symbol-end)))) + (style-region *defstruct-field-style* symbol-start symbol-end) + (when next-start (rd-style-forms :start next-start :end field-end)))) + (t + (style-region *defstruct-field-style* field-start field-end)))) + (setq pos (mark-prev form-end)))) + +(defMacro ancestor () + "Style a structure's ancestor." + `(when pos #+sax-debug (when (and debug-function-p *ancestor-debug*) + (debug-out "~%~%~S" 'ancestor)) + (let* ((start (next-sexpr-start (mark-next pos))) + (end (when start (sexpr-end start))) + (string (when (and start end) (region-to-string (region start end)))) + ancestor-start) + (when (and string (string-equal string ":include")) + (style-region *keyword-package-style* start end) + (when (setq ancestor-start (next-sexpr-start end)) + (style-region *defstruct-ancestor-style* ancestor-start + (sexpr-end ancestor-start))) + (setq pos (next-sexpr-start (sexpr-end pos))))))) + +(defMacro macro () + "Style the name of the macro." + `(when pos #+sax-debug (when (and debug-function-p *macro-debug*) + (debug-out "~%~%~S" 'macro)) + (let ((pos-end (sexpr-end pos))) + #+sax-debug (when (and debug-function-p *macro-debug*) + (debug-out "~%pos-end: ~S" pos-end)) + (when pos-end + (style-region macro-style pos pos-end) + (setq pos (next-sexpr-start pos-end)))))) + +(defMacro derivation-list () + "Style the DEFCLASS derivation list." + `(when pos #+sax-debug (when (and debug-function-p *derivation-list-debug*) + (debug-out "~%~%~S" 'derivation-list)) + (let* ((pos-char (mark-char pos)) + (pos-next (mark-next pos)) + (pos-end (sexpr-end pos)) + (end-prev (when pos-end (mark-prev pos-end)))) + (when (and pos-next end-prev pos-char (char= pos-char #\()) + #+sax-debug (when (and debug-function-p *derivation-list-debug*) + (debug-out "~%pos-next: ~S" pos-next) + (debug-out "~%end-prev: ~S" end-prev)) + (style-region *defclass-derivation-style* pos-next end-prev)) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro slot-list () + "Style DEFCLASS slots." + `(when pos #+sax-debug (when (and debug-function-p *derivation-list-debug*) + (debug-out "~%~%~S" 'slot-list)) + (let (slot-positions + (pos-end (sexpr-end pos))) + (do ((current-start (sexpr-start (mark-prev pos-end)) + (sexpr-start (mark-prev current-start)))) + ((mark<= current-start pos)) + (when (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* current-start) + (mark<= *inc-pos* (sexpr-end current-start)))) + (push current-start slot-positions))) + (dolist (slot-position slot-positions) + (rd-style-forms :start slot-position :end (sexpr-end slot-position)) + (style-region *defclass-slot-style* (mark-next slot-position) + (sexpr-end (mark-next slot-position)))) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro qualifier () + "Style method qualifiers." + `(when pos #+sax-debug (when (and debug-function-p *qualifier-debug*) + (debug-out "~%~%~S" 'qualifier)) + (let ((pos-end (sexpr-end pos))) + (when (char= (mark-char pos) #\:) + (style-region *keyword-package-style* pos pos-end) + (setq pos (next-sexpr-start pos-end)))))) + +(defun list-regions (start end &aux e1-start e1-end e2-start e2-end) + "List parameter and specializer or optional parameter and defaults." + (declare (ignorable end)) + #+sax-debug (when (and debug-function-p *list-regions-debug*) + (debug-out "~%~%~S" 'list-regions) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end)) + (setq e1-end (sexpr-end (mark-next start)) + e1-start (sexpr-start e1-end)) + (setq e2-start (next-sexpr-start (mark-next e1-end)) + e2-end (sexpr-end e2-start)) + (list e1-start e1-end e2-start e2-end)) + +(defun parameter-regions (list-start) + "Collect specialized and non-specialized parameter regions. Style the defaults for + lambda-list-keyword parameters." + #+sax-debug (when (and debug-function-p *parameter-regions-debug*) + (debug-out "~%~%~S" 'parameter-regions)) + (let ((list-end (sexpr-end list-start)) + results option-p) + (do* ((start (next-sexpr-start (mark-next list-start)) + (when (sexpr-end start) (next-sexpr-start (sexpr-end start)))) + (char (when start (mark-char start)) (when start (mark-char start)))) + ((or (null start) (mark>= start list-end)) results) + #+sax-debug (when (and debug-function-p *parameter-regions-debug*) + (debug-out "~%start: ~S" start)) + (cond ((char= char #\() + (let ((specializer-regions (list-regions start (sexpr-end start)))) + #+sax-debug (when (and debug-function-p *parameter-regions-debug*) + (debug-out "~%specializer-regions: ~S" specializer-regions)) + (when (and option-p (third specializer-regions) (fourth specializer-regions)) + (rd-style-forms :start (third specializer-regions) :end (fourth specializer-regions))) + (push (subseq specializer-regions 0 (when option-p 2)) + results))) + ((char= char #\&) + (style-region *keyword-package-style* start (sexpr-end start)) + (setq option-p t)) + (t + (push (list start (sexpr-end start)) results)))))) + +(defMacro parameter-list () + "Style the parameter list. This is called by both functions and methods." + `(when pos #+sax-debug (when (and debug-function-p *parameter-list-debug*) + (debug-out "~%~%~S" 'parameter-list)) + (let ((parameter-regions (parameter-regions pos))) + #+sax-debug (when (and debug-function-p *parameter-list-debug*) + (debug-out "~%parameter-regions: ~S" parameter-regions)) + (dolist (arg parameter-regions) + (style-region *parameter-style* (first arg) (second arg)) + (when (and (third arg) (fourth arg)) + #+sax-debug (when (and debug-function-p *parameter-list-debug*) + (debug-out "~%third: ~S" (third arg)) + (debug-out "~%fourth: ~S" (fourth arg)) + (debug-out "~%*specializer-style*: ~S" *specializer-style*)) + (style-region *specializer-style* (third arg) (fourth arg)))) + (setq pos (next-sexpr-start (sexpr-end pos)))))) + +(defMacro embedded-function-definitions () + "Style the functions defined by LABELS and FLET." + `(when pos #+sax-debug (when (and debug-function-p *embedded-function-definitions-debug*) + (debug-out "~%~%~S" 'embedded-function-definitions)) + (let ((pos-end (sexpr-end pos))) + (do ((position (next-sexpr-start (mark-next pos)) + (next-sexpr-start (nmark-next (sexpr-end position))))) + ((or (null position) (mark>= position pos-end))) + (embedded-function-styling-function (clone position))) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro variable-definitions () + "Style the variables and default values defined by LET, DO*, etc." + `(when pos #+sax-debug (when (and debug-function-p *variable-definitions-debug*) + (debug-out "~%~%~S" 'variable-definitions) + (debug-out "~%pos: ~S" pos)) + (let ((pos-end (sexpr-end pos))) + (do ((position (next-sexpr-start (mark-next pos)) + (next-sexpr-start (nmark-next (sexpr-end position))))) + ((or (null position) (mark>= position pos-end))) + #+sax-debug (when (and debug-function-p *variable-definitions-debug*) + (debug-out "~%variable-definition position: ~S" position)) + (variable-definition-styling-function (clone position))) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro case-match-forms () + "Style the match forms of a case statement" + `(when pos #+sax-debug (when (and debug-function-p *case-match-forms-debug*) + (debug-out "~%~%~S" 'case-match-forms)) + (let ((end (mark-prev form-end))) + (do ((position (next-sexpr-start pos) + (next-sexpr-start (nmark-next (sexpr-end position))))) + ((or (null position) (mark>= position end))) + (case-match-styling-function position)) + (setq pos (next-sexpr-start end))))) + +(defMacro loop-test () + "Style the test form used by an iteration macro." + `(when pos #+sax-debug (when (and debug-function-p *loop-test-debug*) + (debug-out "~%~%~S" 'loop-test)) + (let ((pos-end (sexpr-end pos))) + (rd-style-forms :start pos :end pos-end) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro variable-form () + "Style the initialization form of a variable definition." + `(when pos #+sax-debug (when (and debug-function-p *variable-form-debug*) + (debug-out "~%~%~S" 'variable-form)) + (let ((pos-end (sexpr-end pos))) + (variable-definition-styling-function pos) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro variable-list () + "Style the variable list of multiple-value-setq, multiple-value-bind, etc." + `(when pos #+sax-debug (when (and debug-function-p *variable-list-debug*) + (debug-out "~%~%~S" 'variable-list)) + (let ((pos-end (sexpr-end pos))) + (do* ((var-start (next-sexpr-start (mark-next pos)) + (next-sexpr-start (nmark-next var-end))) + (var-end (when var-start (sexpr-end var-start)) + (when var-start (sexpr-end var-start)))) + ((or (null var-start) (mark> var-start pos-end))) + (style-region *variable-definition-symbol-style* var-start var-end nil)) + (setq pos (next-sexpr-start pos-end))))) + +(defMacro body () + "Style the body of a macro." + `(when pos #+sax-debug (when (and debug-function-p *body-debug*) + (debug-out "~%~%~S" 'body) + (debug-out "~%pos: ~S" pos) + (debug-out "~%form-end: ~S" form-end)) + (rd-style-forms :start pos :end (mark-prev form-end)) + (setq pos (mark-prev form-end)))) + +(defMacro loop-body () + "Style the body of a loop macro." + `(when pos #+sax-debug (when (and debug-function-p *loop-body-debug*) + (debug-out "~%~%~S" 'loop-body)) + (style-elements pos (mark-prev form-end) t) + (setq pos (mark-prev form-end)))) + +(defMacro form () + "Style a single form." + `(when pos #+sax-debug (when (and debug-function-p *form-debug*) + (debug-out "~%~%~S" 'form) + (debug-out "~%pos: ~S" pos)) + (let ((pos-end (sexpr-end pos))) + #+sax-debug (when (and debug-function-p *form-debug*) + (debug-out "~%pos-end: ~S" pos-end)) + (rd-style-forms :start pos :end pos-end) + (setq pos (if (next-sexpr-start pos-end) + (mark-min (or (mark-prev form-end) form-end) + (next-sexpr-start pos-end)) + (mark-prev form-end)))))) + +(defMacro doc () + "Style the doc in DEFUN, DEFMETHOD, DEFMACRO, DEFPARAMETER, etc." + `(when pos #+sax-debug (when (and debug-function-p *doc-debug*) + (debug-out "~%~%~S" 'doc)) + (let ((pos-end (sexpr-end pos))) + (cond ((mark< pos form-end) + (cond ((char-equal #\" (mark-char pos)) + (cond (*inc-p* + (style-region *string-style* + pos (mark-min *inc-pos* (or pos-end pos)) + nil)) + (t + (style-region *string-style* pos pos-end nil))) + (setq pos (if (next-sexpr-start pos-end) + (if (mark< (mark-prev form-end) + (next-sexpr-start pos-end)) + (mark-prev form-end) + (next-sexpr-start pos-end)) + (mark-prev form-end)))) + (t + pos))) + (t + form-end))))) + +(defMacro options () + "Style DEFCLASS and DEFGENERIC options." + `(when pos #+sax-debug (when (and debug-function-p *options-debug*) + (debug-out "~%~%~S" 'options)) + (do* ((option-start pos (next-sexpr-start (sexpr-end option-start))) + (symbol-start (when option-start (mark-next option-start)) + (when option-start (mark-next option-start))) + (symbol-end (when symbol-start (sexpr-end symbol-start)) + (when symbol-start (sexpr-end symbol-start)))) + ((or (null symbol-start) (mark>= symbol-start form-end))) + (when (char-equal #\: (mark-char symbol-start)) + (style-region *keyword-package-style* symbol-start symbol-end nil) + (cond ((string-equal (region-to-string (region symbol-start symbol-end)) + ":documentation") + (when (next-sexpr-start symbol-end) + (style-region *string-style* + (next-sexpr-start symbol-end) + (sexpr-end (next-sexpr-start symbol-end)) nil))) + (t + (when (next-sexpr-start (sexpr-end symbol-start)) + (style-elements (next-sexpr-start symbol-end) form-end)))))) + (setq pos (mark-prev form-end)))) + + +;;; These are called by the macros above: +(defun struct-sym-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defstruct-symbol-style*)) + (optional-paren) (symbl) (ancestor) (body) (optional-paren) pos)) + +(defun embedded-function-styling-function (pos) + #+sax-debug (when *embedded-function-styling-function-debug* + (debug-out "~%~%~S" 'embedded-function-styling-function)) + (let ((form-end (sexpr-end pos)) + (symbol-style *embedded-function-symbol-style*)) + (superparen) (symbl) (parameter-list) (doc) (body) (superparen) pos)) + +(defun variable-definition-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *variable-definition-symbol-style*)) + (optional-paren) (symbl) (body) (optional-paren) pos)) + +(defun case-match-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *case-match-style*)) + (paren) (symbl) (body) (paren) pos)) + +(defun objc-symbol-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *objc-symbol-style*)) + (optional-paren) (symbl) (body) (optional-paren) pos)) + + +;;; The defstyle styles: +(defun defpackage-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defpackage-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (body) (superparen))) + +(add-style "defpackage" #'defpackage-styling-function) + +(defun defparameter-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defparameter-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (form) (doc) (superparen))) + +(add-style "defparameter" #'defparameter-styling-function) + +(defun defvar-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defvar-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (form) (doc) (superparen))) + +(add-style "defvar" #'defvar-styling-function) + +(defun defconstant-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defconstant-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (form) (doc) (superparen))) + +(add-style "defconstant" #'defconstant-styling-function) + +(defun defclass-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defclass-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (derivation-list) (slot-list) (options) (superparen))) + +(add-style "defclass" #'defclass-styling-function) + +(defun defun-styling-function (pos) + #+sax-debug (when *defun-styling-function-debug* + (debug-out "~%~%~S" 'defun-styling-function)) + (let ((form-end (sexpr-end pos)) + (symbol-style *defun-symbol-style*) + (macro-style *defun-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (doc) (body) (superparen))) + +(add-style "defun" #'defun-styling-function) + +(defun defmacro-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defmacro-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (doc) (body) (superparen))) + +(add-style "defmacro" #'defmacro-styling-function) + +(defun define-compiler-macro-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *generic-function-symbol-style*) + (macro-style *defun-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (doc) (body) (superparen))) + +(add-style "define-compiler-macro" #'define-compiler-macro-styling-function) + +(defun define-modify-macro-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *generic-function-symbol-style*) + (macro-style *defun-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (form) (doc) (superparen))) + +(add-style "define-modify-macro" #'define-modify-macro-styling-function) + +(defun define-setf-expander-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *generic-function-symbol-style*) + (macro-style *defun-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (doc) (body) (superparen))) + +(add-style "define-setf-expander" #'define-setf-expander-styling-function) + +(defun define-condition-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *generic-function-symbol-style*) + (macro-style *defun-macro-style*)) + (superparen) (macro) (symbl) (derivation-list) (slot-list) (options) (superparen))) + +(add-style "define-condition" #'define-condition-styling-function) + +(defun defgeneric-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defgeneric-symbol-style*) + (macro-style *generic-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (options) (superparen))) + +(add-style "defgeneric" #'defgeneric-styling-function) + +(defun defmethod-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defmethod-symbol-style*) + (macro-style *generic-macro-style*)) + (when pos + (superparen) (macro) (symbl) (qualifier) (parameter-list) (doc) (body) (superparen)))) + +(add-style "defmethod" #'defmethod-styling-function) + +(defun objc-defmethod-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *objc-macro-style*)) + (superparen) (macro) (objc-symbl pos) (parameter-list) (doc) (body) (superparen))) + +(add-style "objc:defmethod" #'objc-defmethod-styling-function) + +(defun defcommand-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (symbol-style *defcommand-symbol-style*) + (macro-style *defcommand-macro-style*)) + (superparen) (macro) (symbl) (parameter-list) (doc) (doc) (body) (superparen))) + +(add-style "hemlock::defcommand" #'defcommand-styling-function) + +(defun labels-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (embedded-function-definitions) (body) (paren))) + +(add-style "labels" #'labels-styling-function) + +(defun lambda-styling-function (pos) + #+sax-debug (when *lambda-styling-function-debug* + (debug-out "~%~%~S" 'lambda-styling-function)) + (let ((form-end (sexpr-end pos)) + (macro-style *lambda-macro-style*)) + (superparen) (macro) (parameter-list) (doc) (body) (superparen))) + +(add-style "lambda" #'lambda-styling-function) + +(defun flet-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (embedded-function-definitions) (body) (paren))) + +(add-style "flet" #'flet-styling-function) + +(defun loop-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *loop-macro-style*)) + (loop-superparen) (macro) (loop-body) (loop-superparen))) + +(add-style "loop" #'loop-styling-function) + +(defun defstruct-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *generic-macro-style*)) + (superparen) (macro) (struct-sym) (doc) (struct-fields) (superparen))) + +(add-style "defstruct" #'defstruct-styling-function) + +(defun dotimes-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-form) (body) (paren))) + +(add-style "dotimes" #'dotimes-styling-function) + +(defun dolist-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-form) (body) (paren))) + +(add-style "dolist" #'dolist-styling-function) + +(defun multiple-value-bind-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-list) (body) (paren))) + +(add-style "multiple-value-bind" #'multiple-value-bind-styling-function) + +(defun multiple-value-setq-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-list) (body) (paren))) + +(add-style "multiple-value-setq" #'multiple-value-setq-styling-function) + +(defun destructuring-bind-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (parameter-list) (body) (paren))) + +(add-style "destructuring-bind" #'destructuring-bind-styling-function) + +(defun do-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (form) (body) (paren))) + +(add-style "do" #'do-styling-function) + +(defun do*-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (form) (body) (paren))) + +(add-style "do*" #'do-styling-function) + +(defun let-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (body) (paren))) + +(add-style "let" #'let-styling-function) + +(defun let*-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (body) (paren))) + +(add-style "let*" #'let-styling-function) + +(defun prog-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (body) (paren))) + +(add-style "prog" #'prog-styling-function) + +(defun prog*-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (body) (paren))) + +(add-style "prog*" #'prog*-styling-function) + +(defun with-slots-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (form) (body) (paren))) + +(add-style "with-slots" #'with-slots-styling-function) + +(defun with-accessors-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-definitions) (form) (body) (paren))) + +(add-style "with-accessors" #'with-accessors-styling-function) + +(defun with-open-file-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (variable-form) (body) (paren))) + +(add-style "with-open-file" #'with-open-file-styling-function) + +(defun macrolet-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (embedded-function-definitions) (body) (paren))) + +(add-style "macrolet" #'macrolet-styling-function) + +(defun case-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (paren) (macro) (form) (case-match-forms) (paren))) + +(add-style "case" #'case-styling-function) +(add-style "ccase" #'case-styling-function) +(add-style "ecase" #'case-styling-function) +(add-style "typecase" #'case-styling-function) +(add-style "etypecase" #'case-styling-function) +(add-style "ctypecase" #'case-styling-function) + +(defun eval-when-styling-function (pos) + (let ((form-end (sexpr-end pos)) + (macro-style *cl-package-style*)) + (eval-when-superparen) (macro) (form) (body) (eval-when-superparen))) + +(add-style "eval-when" #'eval-when-styling-function) + +;;; history-lists.lisp needs this, for now: +(pushnew :syntax-styling *features*) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-comments.lisp =================================================================== --- /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-comments.lisp (revision 13073) +++ /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-comments.lisp (revision 13073) @@ -0,0 +1,400 @@ +;;;-*- Mode: Lisp; Package: (SYNTAX-STYLING (CL CCL HEMLOCK-INTERNALS)) -*- + +;;; **************************************************************************** +;;; +;;; syntax-styling-comments.lisp +;;; +;;; copyright © 2009 Glen Foy, all rights reserved, +;;; +;;; These classes support the styling of semi-colon and sharp-stroke comments, +;;; and strings. Most unusual cases are correctly handled: strings embedded in +;;; comments, comments inside of strings, etc. +;;; +;;; Mod history, most recent first: +;;; 10/18/9 first cut. +;;; +;;; **************************************************************************** + +(in-package "SAX") + + +;;; ---------------------------------------------------------------------------- +;;; +(defClass STYLED-COMMENT () + ((comment-start :initarg :comment-start :initform nil :reader comment-start) + (comment-end :initform nil :initarg :comment-end :reader comment-end)) + (:documentation "Support for styled comments.")) + +(defClass STYLED-SEMI-COLON-COMMENT (styled-comment) ()) + +(defClass STYLED-SHARP-COMMENT (styled-comment) ()) + +(defMethod style-comment ((comment styled-semi-colon-comment)) + (set-style-attributes (attribute-dictionary *semi-colon-comment-style*) + (comment-start comment) (comment-end comment))) + +(defMethod style-comment ((comment styled-sharp-comment)) + (set-style-attributes (attribute-dictionary *sharp-comment-style*) + (comment-start comment) (comment-end comment))) + +;;; ---------------------------------------------------------------------------- +;;; +(defClass STYLED-STRING () + ((string-start :initarg :string-start :initform nil :reader string-start) + (string-end :initform nil :initarg :string-end :reader string-end)) + (:documentation "Support for styled strings.")) + +(defMethod style-string ((string styled-string)) + (cond (*inc-p* ; if dynamic, never style past *inc-pos* + (set-style-attributes (attribute-dictionary *string-style*) + (string-start string) *inc-pos*)) + (t + (set-style-attributes (attribute-dictionary *string-style*) + (string-start string) (string-end string))))) + +;;; ---------------------------------------------------------------------------- +;;; +(defClass SEGMENT-ARRAY () + ((array :initarg :array :reader segment-array-array) + (length :initarg :length :accessor segment-array-length)) + (:documentation + "A sorted 2d array of the start and end positions for segments in +a buffer. There are three segment types: strings, semi-colon comments, +and sharp-stroke comments. The method not-embedded-in-segment-p does + a binary search for the position of a particular char to see if the +char is embedded.")) + +(defMethod print-object ((array segment-array) stream) + (declare (ignore stream)) + #+sax-debug (when *print-object-segment-array-debug* + (dump-segment-array array)) + #-sax-debug (call-next-method)) + +(defmethod dump-segment-array ((a segment-array)) + (format t "~%~%segment-array length: ~S" (segment-array-length a)) + (dotimes (idx (segment-array-length a)) + (format t "~% ~S" (aref (segment-array-array a) idx 0)) + (format t "~% ~S~%" (aref (segment-array-array a) idx 1)))) + +(defun unify-segment-lists (segment-list-1 segment-list-2) + "Merge two lists, discarding segments which are embedded in segments of the other list." + (do* ((list-1 segment-list-1) + (list-2 segment-list-2) + (segment-1 (first list-1) (first list-1)) + (segment-2 (first list-2) (first list-2)) + (unified-list nil)) + ((and (endp list-1) (endp list-2)) (nreverse unified-list)) + (cond ((and list-1 list-2) + (cond ((mark< (first segment-1) (first segment-2)) + (cond ((mark< (first segment-2) (second segment-1)) + (pop list-2)) + (t + (push segment-1 unified-list) + (pop list-1)))) + (t + (cond ((mark< (first segment-1) (second segment-2)) + (pop list-1)) + (t + (push segment-2 unified-list) + (pop list-2)))))) + (t ; one list is empty - add what's left of the other + (cond ((endp list-1) + (return (append (nreverse unified-list) list-2))) + (t + (return (append (nreverse unified-list) list-1)))))))) + +(defun make-segment-array (table) + "Constructor for the segment-array class." + (let ((table-length (length table))) + (make-instance 'segment-array + :length table-length + :array (make-array `(,table-length 2) + :initial-contents table)))) + +;;; This is called when constructing the segment array and to get a list of strings +;;; to style. When styling dynamically, cull the string list. When constructing the +;;; segment array, don't. +;;; +(defun create-string-list (start end &optional styling-p) + "Return a list of the form, (start end), for each string in buffer. +The list is in reverse order." + (flet ((semi-colon-commented-p (pos) + (do* ((start (mark-move pos 0) (nmark-next start)) + (char (mark-char start) (mark-char start))) + ((mark>= start pos)) + (when (char= char #\;) (return-from semi-colon-commented-p t)))) + (sharp-stroke-commented-p (pos) + (do ((start (clone pos) (nmark-prev start)) + (char (mark-char start) (mark-char start)) + (char-minus-one + (when (>= (mark-charpos start) 1) (mark-char (mark-prev pos))) + (when (>= (mark-charpos start) 1) (mark-char (mark-prev pos))))) + ((or (= (mark-charpos start) 1) + (and (char= char #\#) (char= char-minus-one #\|)))) + (when (and (char= char #\|) + (char= char-minus-one #\|)) + (return-from sharp-stroke-commented-p t))))) + (do* ((position (clone start)) + string-list string-end) + ((or (null position) (mark>= position end)) string-list) + (cond ((and (eql (mark-char position) #\") + (not (eql (mark-char (if (> (mark-charpos position) 0) + (mark-prev position) + position)) #\\)) + ;; Too expensive; may have a rare mis-styled file + ;; because of an unmatched quote in a sharp-comment. + ;; (not (sharp-stroke-commented-p position)) + (not (semi-colon-commented-p position))) + (setf string-end (sexpr-end position)) + (cond ((and string-end (mark<= string-end end)) + ;; Support for dynamic styling - only cull the string list + ;; when styling strings, not when constructing the segment array + (if *inc-p* + (if styling-p + ;; cull + (when (and (mark>= *inc-pos* position) + (mark<= *inc-pos* string-end)) + (push (list position string-end) string-list)) + (push (list position string-end) string-list)) + (push (list position string-end) string-list)) + (setf position (clone string-end))) + (t + (return string-list)))) + (t + (nmark-next position)))))) + +;;; This is only called by get-combined-segment-list, when doing vanilla styling. +(defun create-semi-colon-comment-list (start end ) + "Return a list of the form, (start end), for each comment in buffer." + (do* ((position (clone start)) + comment-list comment-end) + ((or (null position) (mark> position end)) (nreverse comment-list)) + (cond ((and (eql (mark-char position) #\;) + (mark> position (buf-start-mark)) ; *** mode line ??? + (not (eql (mark-char (mark-prev position)) #\\))) + (setf comment-end (line-end (clone position))) + (cond ((and comment-end (mark<= comment-end end)) + (push (list (clone position) (mark-next comment-end)) comment-list) + (setf position (mark-next comment-end))) + (t ; hum ... + (setf position (mark-next position))))) + (t + (setf position (mark-next position)))))) + +;;; This is only called by get-combined-segment-list, when doing vanilla styling. +(defun create-sharp-stroke-comment-list (start end ) + "Return a list of the form, (start end), for each comment in buffer." + (do* ((position (clone start)) + comment-list comment-end) + ((or (null position) (mark> position end)) (nreverse comment-list)) + (cond ((and (eql (mark-char position) #\#) + (eql (mark-char (mark-next position)) #\|) + (mark> position (buf-start-mark)) + (not (eql (mark-char (mark-prev position)) #\\))) + (setf comment-end (pattern-search position *stroke-sharp-forward-pattern* end)) + (cond ((and comment-end (mark<= comment-end end)) + (push (list position comment-end) comment-list) + (setf position (mark-next comment-end))) + (t + (return (nreverse comment-list))))) + (t + (setq position (mark-next position)))))) + +;;; This is only called by get-combined-segment-list, when doing vanilla styling. +(defun create-cocoa-syntax-list (start end pattern) + "Return a list of the form, (start end), for each Cocoa function name in buffer." + (do* ((position (pattern-search (clone start) pattern end) + (pattern-search (clone name-end) pattern end)) + (name-end (when position (sexpr-end position)) (when position (sexpr-end position))) + name-list) + ((or (null position) (null name-end) (mark> position end)) (nreverse name-list)) + (push (list position name-end) name-list))) + +(defMethod not-embedded-in-segment-p ((array segment-array) position) + ;; Do a binary search of the segment-array to see if the position is embedded. + #+sax-debug (when *not-embedded-in-segment-p-debug* + (debug-out "~%~%~S" 'not-embedded-in-segment-p) + (dump-segment-array array) + (debug-out "~%position: ~S" position)) + (when (or (zerop (segment-array-length array)) (null position)) + (return-from not-embedded-in-segment-p t)) + (do* ((top (1- (segment-array-length array))) + (bottom 0) + (index (truncate (+ bottom top) 2) (truncate (+ bottom top) 2))) + ((< top bottom) t) + (when (and (mark< (aref (segment-array-array array) index 0) position) + (mark> (aref (segment-array-array array) index 1) position)) + ;; embedded - return the end of the containing segment as the second value: + (return (values nil (aref (segment-array-array array) index 1)))) + (cond ((mark<= position (aref (segment-array-array array) index 0)) + (setf top (1- index))) + ((mark>= position (aref (segment-array-array array) index 1)) + (setf bottom (1+ index))) + (t (error "~&Bad value in binary search: ~a" position))))) + +(defun embedded-in-segment-p (pos) + (when *segment-array* + (multiple-value-bind (not-embedded-p end-of-segment) + (not-embedded-in-segment-p *segment-array* pos) + (values (not not-embedded-p) end-of-segment)))) + +(defun style-strings (&optional (start (buf-start-mark)) (end (buf-end-mark)) + &aux string-instances) + #+sax-debug (when *style-strings-debug* + (debug-out "~%~%~S" 'style-strings)) + (setf *segment-list* (create-string-list start end *inc-p*)) + (do* ((string-list *segment-list* (rest string-list)) + (start-string (first (first string-list)) (first (first string-list))) + (end-string (second (first string-list)) (second (first string-list)))) + ((null start-string)) + (push (make-instance 'styled-string + :string-start start-string + :string-end end-string) + string-instances)) + ;; Create the segment array - if styling dynamically. + ;; Create the inclusive string list for the segment array. + (setf *segment-array* (make-segment-array + (if *inc-p* + (setf *segment-list* (nreverse (create-string-list start end))) + (setf *segment-list* (nreverse *segment-list*))))) + (dolist (string string-instances) + (style-string string)) + string-instances) + +(defun style-semi-colon-comments (&optional (start (buf-start-mark)) (end (buf-end-mark))) + #+sax-debug (when *style-semi-colon-comments-debug* + (debug-out "~%~%~S" 'style-semi-colon-comments)) + (let ((comment-instances nil) + (comment-segment-list nil)) + (do* ((start-comment (pattern-search start *semicolon-forward-pattern* end) + (pattern-search end-comment *semicolon-forward-pattern* end)) + (end-comment (when start-comment (line-end (clone start-comment))) + (when start-comment (line-end (clone start-comment))))) + ((or (not start-comment) + (not end-comment) + (mark> start-comment end))) + #+sax-debug (when *style-semi-colon-comments-debug* + (debug-out "~%start-comment: ~S" start-comment) + (debug-out "~%end-comment: ~S" end-comment)) + + ;; The first AND handles the case where a string spans two comments. + (when (or (and (mark= start-comment (mark-line-start start-comment)) + (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* start-comment) + (mark<= (mark-prev *inc-pos*) end-comment)))) + ;; with dynamically-style-comments *segment-array* may not be there yet. + (and (not (embedded-in-segment-p start-comment)) + (not (and (>= (mark-charpos start-comment) 2) + (eq (mark-char start-comment -1) #\\) + (eq (mark-char start-comment -2) #\#))))) + ;; Need the entire segment array for accurate parsing, even when + ;; not styling this comment: + (push (list start-comment end-comment) comment-segment-list) + (when (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* start-comment) + (mark<= (mark-prev *inc-pos*) end-comment))) + (push (make-instance 'styled-semi-colon-comment + :comment-start start-comment + :comment-end end-comment) + comment-instances)))) + (setf *segment-list* + (unify-segment-lists (nreverse comment-segment-list) *segment-list*)) + (setf *segment-array* (make-segment-array *segment-list*)) + (setf comment-instances (nreverse comment-instances)) + (dolist (comment comment-instances) + (style-comment comment)) + comment-instances)) + +(defun style-sharp-comments (&optional (start (buf-start-mark)) (end (buf-end-mark))) + (flet ((find-end-comment (start-comment) + (do* ((level-count 1) + (next-end-comment (pattern-search start-comment *stroke-sharp-forward-pattern* end) + (when next-start-comment + (pattern-search (nmark-offset next-start-comment 2) *stroke-sharp-forward-pattern* end))) + (next-start-comment (pattern-search (nmark-offset start-comment 2) *sharp-stroke-forward-pattern* end) + (when next-start-comment + (pattern-search (nmark-offset next-start-comment 2) *sharp-stroke-forward-pattern* end)))) + ((null next-end-comment)) + (when (and next-start-comment (mark< next-start-comment next-end-comment)) + ;; nested + (incf level-count)) + (decf level-count) + (when (= level-count 0) (return next-end-comment))))) + (let ((comment-instances nil) + (comment-segment-list nil)) + (do* ((start-comment (pattern-search start *sharp-stroke-forward-pattern* end) + (pattern-search end-comment *sharp-stroke-forward-pattern* end)) + (end-comment (when (and start-comment (mark<= start-comment end)) ; *** redundant + (find-end-comment start-comment)) + (when (and start-comment (mark<= start-comment end)) + (find-end-comment start-comment)))) + ((or (not start-comment) + (not end-comment))) + (cond ((and (not-embedded-in-segment-p *segment-array* start-comment) + (not-embedded-in-segment-p *segment-array* end-comment) + (or (not *inc-p*) + (and *inc-p* + (mark>= *inc-pos* start-comment) + (mark<= (mark-offset *inc-pos* -3) end-comment)))) + (push (list start-comment end-comment) comment-segment-list) + (push (make-instance 'styled-sharp-comment + :comment-start (mark-offset start-comment -2) + :comment-end (mark-offset end-comment 2)) + comment-instances)))) + (when comment-instances + (setf *segment-list* (unify-segment-lists (nreverse comment-segment-list) *segment-list*)) + (setf *segment-array* (make-segment-array *segment-list*)) + (setf comment-instances (nreverse comment-instances)) + (dolist (comment comment-instances) + (style-comment comment)) + comment-instances)))) + +(defun style-comments (start end) + (style-strings start end) + (style-semi-colon-comments start end) + (style-sharp-comments start end)) + +(defun dynamically-style-comments (start end style-strings-p style-semi-colon-comments-p) + #+sax-debug (when *dynamically-style-comments-debug* + (debug-out "~%~%~S" 'dynamically-style-comments)) + (let ((hi::*current-buffer* *buf*)) + (hemlock::parse-over-block (mark-line start) (mark-line end)) + (when style-strings-p (style-strings start end)) + (when style-semi-colon-comments-p + ;; (style-semi-colon-comments (mark-line-start end) end)))) + ;; Start is necessary to generate an complete segment-array for subsequent styling: + (style-semi-colon-comments start end)))) + +;;; *** this needs to use start and end +(defun get-combined-segment-list () + (let* ((start (buf-start-mark)) + (end (buf-end-mark)) + (string-list (nreverse (create-string-list start end))) + (semi-colon-comment-list (create-semi-colon-comment-list start end)) + (sharp-stroke-comment-list (create-sharp-stroke-comment-list start end)) + (cocoa-function-list (create-cocoa-syntax-list start end *sharp-slash-forward-pattern*)) + (cocoa-constant1-list (create-cocoa-syntax-list start end *sharp-dollar-forward-pattern*)) + (cocoa-constant2-list (create-cocoa-syntax-list start end *sharp-ampersand-forward-pattern*)) + (cocoa-constant3-list (create-cocoa-syntax-list start end *colon-lessthan-forward-pattern*)) + (cocoa-constant4-list (create-cocoa-syntax-list start end *sharp-backslash-forward-pattern*))) + (unify-segment-lists + string-list + (unify-segment-lists + cocoa-constant1-list + (unify-segment-lists + cocoa-constant2-list + (unify-segment-lists + cocoa-constant3-list + (unify-segment-lists + cocoa-constant4-list + (unify-segment-lists + cocoa-function-list + (unify-segment-lists + semi-colon-comment-list + sharp-stroke-comment-list))))))))) + + + + Index: /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-specials.lisp =================================================================== --- /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-specials.lisp (revision 13073) +++ /release/1.4/source/contrib/foy/syntax-styling/syntax-styling-specials.lisp (revision 13073) @@ -0,0 +1,671 @@ +;;;-*- Mode: Lisp; Package: SYNTAX-STYLING -*- + +;;; **************************************************************************** +;;; +;;; syntax-styling-specials.lisp +;;; +;;; copyright (c) 2009 Glen Foy +;;; (Permission is granted to Clozure Associates to distribute this file.) +;;; +;;; Special variables, utility functions and macros. +;;; +;;; This software is offered "as is", without warranty of any kind. +;;; +;;; Mod History, most recent first: +;;; 10/18/9 First cut. +;;; +;;; **************************************************************************** + +#-sax-debug +(defPackage syntax-styling (:use :cl :ccl :hemlock-internals) (:nicknames "SAX")) + +(in-package "SAX") + +(defParameter *style-case-p* t "To set case, or not to set case.") + +;;; ---------------------------------------------------------------------------- +;;; Configure your style by hacking the colors and style parameters below: +;;; ---------------------------------------------------------------------------- +;;; +(defParameter *black-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.0 0.0 1.0)) +(defParameter *gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0)) +(defParameter *medium-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.30 0.30 0.30 1.0)) +(defParameter *darker-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.11 0.11 0.11 1.0)) +(defParameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.01 0.01 0.01 1.0)) +(defParameter *blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.1 0.65 1.0)) +(defParameter *light-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.35 0.65 1.0)) +(defParameter *green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.0 1.0)) +(defParameter *turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.4 1.0)) +(defParameter *violet-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.15 0.1 0.7 1.0)) +(defParameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.5 0.1 0.2 1.0)) +(defParameter *medium-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.8 0.0 0.2 1.0)) +(defParameter *magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.75 0.0 0.5 1.0)) +(defParameter *dark-magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.0 0.25 1.0)) +(defParameter *brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.2 0.0 1.0)) + +(defParameter *generic-symbol-color* *blue-color*) +(defParameter *generic-macro-color* *wine-red-color*) + +;;; Convert style-spec to an ns-dictionary with the specified attributes. +;;; Temporary text attributes only support color and underlining. +(defun spec-to-dict (font-spec) + (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 2)) + (color (getf font-spec :font-color)) + (underline (getf font-spec :font-underline)) ; :single :double :thick + (underline-int (case underline (:single 1) (:double 2) (:thick 3)))) + (when color (#/setObject:forKey: dict color + #&NSForegroundColorAttributeName)) + (when (and underline underline-int) + (#/setObject:forKey: dict (#/numberWithInt: ns:ns-number underline-int) + #&NSUnderlineStyleAttributeName)) + dict)) + +;;; ---------------------------------------------------------------------------- +;;; The Styles: +;;; ---------------------------------------------------------------------------- +;;; +;;; The cdr of each dotted-pair is the capitalization spec: +(defParameter *vanilla-styling* (cons (spec-to-dict (list :font-color *black-color*)) :down)) +(defParameter *generic-text-style* (cons (spec-to-dict (list :font-color *darker-gray-color*)) :down)) +(defParameter *generic-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap3)) +(defParameter *generic-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down)) +(defParameter *generic-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *embedded-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +;;; This is also the style for lambda-list keywords: +(defParameter *keyword-package-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down)) +(defParameter *cl-package-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down)) +(defParameter *exported-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :double)) :up)) + +(defParameter *semi-colon-comment-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged)) +(defParameter *sharp-comment-style* (cons (spec-to-dict (list :font-color *medium-gray-color*)) :unchanged)) +(defParameter *string-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged)) + +(defParameter *superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged)) +(defParameter *eval-when-superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged)) +(defParameter *loop-superparen-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged)) + +(defParameter *variable-definition-symbol-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down)) +(defParameter *defstruct-field-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down)) +(defParameter *defstruct-ancestor-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down)) +(defParameter *defclass-derivation-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down)) +(defParameter *defclass-slot-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down)) +(defParameter *parameter-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down)) +(defParameter *specializer-style* (cons (spec-to-dict (list :font-color *green-color*)) :unchanged)) +(defParameter *case-match-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down)) + +(defParameter *defpackage-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down)) +(defParameter *defparameter-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down)) +(defParameter *defvar-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down)) +(defParameter *defconstant-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down)) +(defParameter *defclass-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up)) +(defParameter *defun-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *defmacro-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *defgeneric-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *defmethod-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *objc-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged)) +(defParameter *defcommand-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged)) +(defParameter *defstruct-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up)) + +(defParameter *lambda-macro-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) +(defParameter *loop-macro-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :up)) +(defParameter *loop-keyword-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down)) +(defParameter *defun-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :down)) +(defParameter *objc-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap8)) +(defParameter *defcommand-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap12)) + +;;; ---------------------------------------------------------------------------- +;;; Various: +;;; ---------------------------------------------------------------------------- +;;; +(defParameter *styling-p* t "To style or not to style.") +(defParameter *buf* nil "The target buffer.") +(defParameter *layout* nil "The NSLayoutManager of the target text-view.") +(defParameter *current-package* nil "Package used to style exported symbols.") +;;; consolidate these two: +(defParameter *inc-p* nil "Styling incrementally?") +(defParameter *inc-pos* nil "Buffer-point during an incremental parse.") +(defParameter *inside-semi-colon-comment-p* nil) +(defParameter *paste-p* nil "Is a paste in progress?") +(defParameter *paste-start* nil "Starting position of a paste operation.") +(defParameter *paste-end* nil "Ending position of a paste operation.") + +;;; test +(defParameter *style-screen-p* t "To style or not to style the screen after a given operation.") +(defParameter *style-top-level-form-p* nil "To style or not to style the top-level form after a given operation.") +(defParameter *segment-list* nil "Comment and string code data structure.") +(defParameter *segment-array* nil "Comment and string code data structure.") + +(defParameter *form-style* nil "The style of the atom being processed incrementally.") +(defParameter *form-start* nil "The start position of the atom being processed incrementally.") +(defParameter *form-end* nil "The end position of the atom being processed incrementally.") +(defParameter *superparen-closure* nil "An ugly hack to style superparens.") + +;;; key-event constants: +(defParameter %control-y% #k"control-y") +(defParameter %control-meta-q% #k"control-meta-q") +(defParameter %control-d% #k"control-d") +(defParameter %backspace% #k"Backspace") +(defParameter %control-j% #k"control-j") +(defparameter %backward-char-event% (hi::get-key-event* 98 8)) + +;;; Search patterns: +(defparameter *l-paren-forward-pattern* (new-search-pattern :character :forward #\()) +(defparameter *l-paren-backward-pattern* (new-search-pattern :character :backward #\()) +(defparameter *sharp-stroke-forward-pattern* (new-search-pattern :string-insensitive :forward "#|")) +(defparameter *stroke-sharp-forward-pattern* (new-search-pattern :string-insensitive :forward "|#")) +(defparameter *semicolon-forward-pattern* (new-search-pattern :character :forward #\;)) +(defParameter *sharp-slash-forward-pattern* (new-search-pattern :string-insensitive :forward "#/")) +(defParameter *sharp-backslash-forward-pattern* (new-search-pattern :string-insensitive :forward "#\\")) +(defParameter *sharp-dollar-forward-pattern* (new-search-pattern :string-insensitive :forward "#$")) +(defParameter *sharp-ampersand-forward-pattern* (new-search-pattern :string-insensitive :forward "#&")) +(defParameter *colon-lessthan-forward-pattern* (new-search-pattern :string-insensitive :forward ":<")) + +;;; ---------------------------------------------------------------------------- +;;; Mark functions and macros. +;;; ---------------------------------------------------------------------------- +;;; +;;; Hemlock's BUFFER is a doubly linked list of LINES. MARKS specify relative positions +;;; within LINES. Programming Hemlock involves a lot of MARK manipulation. These are some +;;; useful macros that operate on MARKS. Destructive and non-destructive versions +;;; are usually provided, using the prepended "n" convention for destructive functions. + +(defmacro clone (mark) `(hi::copy-mark ,mark :temporary)) + +(defmacro set-storage (storage source) + `(progn + (setf (mark-charpos ,storage) (mark-charpos ,source)) + (setf (mark-line ,storage) (mark-line ,source)) + ,storage)) + +;;; Needs to support nested forms as in: (mark-next (sexpr-end pos)), +;;; only evaluating MARK-OR-FORM once. +;;; No error, if MARK-OR-FORM evaluates to nil, just return nil. +(defmacro mark-next (mark-or-form) + (let ((param (gensym)) + (new-mark (gensym))) + `(let ((,param ,mark-or-form)) + (when ,param + (let ((,new-mark (clone ,param))) + (setq ,new-mark (mark-after ,new-mark)) + #+sax-debug (when (and *mark-next-debug* (null ,new-mark)) + (debug-out "~%mark-next returning nil.")) + ,new-mark))))) + +(defmacro nmark-next (mark-or-form) + (let ((param (gensym))) + `(let ((,param ,mark-or-form)) + (when ,param (mark-after ,param))))) + +(defmacro mark-prev (mark-or-form) + (let ((param (gensym)) + (new-mark (gensym))) + `(let ((,param ,mark-or-form)) + (when ,param + (let ((,new-mark (clone ,param))) + (setq ,new-mark (mark-before ,new-mark)) + #+sax-debug (when (and *mark-prev-debug* (null ,new-mark)) + (debug-out "~%mark-prev returning nil.")) + ,new-mark))))) + +(defmacro nmark-prev (mark-or-form) + (let ((param (gensym))) + `(let ((,param ,mark-or-form)) + (when ,param (mark-before ,param))))) + +;;; This does not cross lines +(defmacro mark-char (mark &optional offset) + (if offset + (let ((line (gensym)) + (line-length (gensym)) + (mark-charpos (gensym)) + (offset-position (gensym))) + `(when ,mark + (let* ((,line (mark-line ,mark)) + (,line-length (line-length ,line)) + (,mark-charpos (mark-charpos ,mark)) + (,offset-position (+ ,mark-charpos ,offset))) + (cond ((and (<= 0 ,offset-position) ; offset can be negative + (< ,offset-position ,line-length)) + (line-character ,line ,offset-position)) + (t + nil))))) + `(when ,mark + (next-character ,mark)))) + +(defmacro mark-move (mark pos) + (let ((new-mark (gensym))) + `(when ,mark + (let ((,new-mark (clone ,mark))) + (move-to-position ,new-mark ,pos))))) + +(defmacro nmark-move (mark pos) + `(move-to-position ,mark ,pos)) + +(defmacro mark-line-start (mark) + (let ((new-mark (gensym))) + `(when ,mark + (let ((,new-mark (clone ,mark))) + (line-start ,new-mark))))) + +(defmacro mark-offset (mark offset) + (let ((new-mark (gensym))) + `(when ,mark + (let ((,new-mark (clone ,mark))) + (character-offset ,new-mark ,offset))))) + +(defmacro nmark-offset (mark offset) + `(when ,mark + (character-offset ,mark ,offset) + ,mark)) + +(defMacro mark-min (m1 m2) `(if (mark< ,m1 ,m2) ,m1 ,m2)) + +(defMacro mark-max (m1 m2) `(if (mark> ,m1 ,m2) ,m1 ,m2)) + +(defmacro buf-end-mark (&optional buffer) + `(clone (buffer-end-mark (if ,buffer ,buffer *buf*)))) + +(defmacro buf-start-mark (&optional buffer) + `(clone (buffer-start-mark (if ,buffer ,buffer *buf*)))) + +;;; ---------------------------------------------------------------------------- +;;; Buffer functions and macros. +;;; ---------------------------------------------------------------------------- +;;; +(defmacro buffer-empty-p () `(mark= (buffer-start-mark *buf*) (buffer-end-mark *buf*))) + +(defun buffer-line-start (buffer &optional storage) + (let ((line (mark-line (buffer-point buffer)))) + (cond (storage + (setf (mark-line storage) line) + (setf (mark-charpos storage) 0) + storage) + ( + (mark line 0))))) + +(defun buffer-line-end (buffer &optional storage) + (let ((line (mark-line (buffer-point buffer)))) + (cond (storage + (setf (mark-line storage) line) + (setf (mark-charpos storage) (line-length line))) + (t + (mark line (line-length line)))))) + +;;; ---------------------------------------------------------------------------- +;;; Lisp syntax functions and macros. +;;; ---------------------------------------------------------------------------- +;;; +(defmacro sexpr-end (start) + (let ((sexpr-start (gensym)) + (sexpr-end (gensym))) + `(when ,start + (let* ((,sexpr-start (clone ,start)) + (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start))) + (if ,sexpr-end + ,sexpr-end + #+sax-debug (when *sexpr-end-debug* + (debug-out "~%sexpr-end returning nil - start-mark: ~S" ,start))))))) + +(defmacro sexpr-start (pos) + (let ((sexpr-start (gensym))) + `(when ,pos + (let ((,sexpr-start (clone ,pos))) + (if (hemlock::form-offset ,sexpr-start -1) + ,sexpr-start + #+sax-debug (when *sexpr-start-debug* + (debug-out "~%sexpr-start returning nil - pos-mark: ~S" ,pos))))))) + +(defmacro limited-sexpr-end (start limit) + (let ((sexpr-start (gensym)) + (sexpr-end (gensym))) + `(when ,start + #+sax-debug (when *limited-sexpr-end-debug* + (debug-out "~%~%~S" 'limited-sexpr-end) + (debug-out "~%start: ~S" ,start) + (debug-out "~%limit: ~S" ,limit)) + (let* ((,sexpr-start (clone ,start)) + (,sexpr-end (when (hemlock::form-offset ,sexpr-start 1) ,sexpr-start))) + #+sax-debug (when *limited-sexpr-end-debug* + (debug-out "~%sexpr-end: ~S" ,sexpr-end)) + (if ,sexpr-end + (when (mark<= ,sexpr-end ,limit) ,sexpr-end) + #+sax-debug (when *limited-sexpr-end-debug* + (debug-out "~%limited-sexpr-end returning nil - start-mark: ~S" ,start))))))) + +(defmacro next-sexpr-start (mark-or-form) + (let ((position (gensym)) + (forward (gensym)) + (start (gensym)) + (param (gensym))) + ;; evaluate mark-or-form once, only: + `(let ((,param ,mark-or-form)) + (when ,param + #+sax-debug (when *next-sexpr-start-debug* + (debug-out "~%next-sexpr-start mark-or-form: ~S" ,mark-or-form) + (debug-out "~%next-sexpr-start param: ~S" ,param)) + (do* ((,position (clone ,param)) + (,forward (when (hemlock::form-offset ,position 1) ,position) + (when (hemlock::form-offset ,position 1) ,position)) + (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward)) + (when ,forward (when (hemlock::form-offset ,forward -1) ,forward)))) + ((or (null ,start) (mark>= ,start ,param)) + #+sax-debug (when (and *next-sexpr-start-debug* (null ,start)) + (debug-out "~%next-sexpr-start returning nil")) + (if *inc-p* + (when (and ,start (mark< ,start *inc-pos*)) + ,start) + ,start)) + #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%start: ~S" ,start)) + (hemlock::form-offset ,position 1) + #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%(form-offset position 1): ~S" ,position)) + (cond ((null ,position) + #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning nil")) + (return nil)) + ((mark<= ,position ,param) + ;; wretched special case: avoid getting stuck: ie. (eq ,errsym #.^#$ o ) + #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning (mark-next ,position)")) + (set-storage ,position ,param) + (return (mark-next ,position))))))))) + +(defMacro nnext-sexpr-start (mark-or-form) + (let ((position (gensym)) + (forward (gensym)) + (start (gensym)) + (param (gensym))) + `(let ((,param ,mark-or-form)) + (when ,param + #+sax-debug (when *nnext-sexpr-start-debug* + (debug-out "~%nnext-sexpr-start mark-or-form: ~S" ,mark-or-form) + (debug-out "~%nnext-sexpr-start param: ~S" ,param)) + (let* ((,position ,param) + (,forward (when (hemlock::form-offset ,position 1) ,position)) + (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward)))) + #+sax-debug (when *nnext-sexpr-start-debug* + (if (null ,start) + (debug-out "~%nnext-sexpr-start returning nil") + (debug-out "~%nnext-sexpr-start returning: ~S" ,start))) + (if *inc-p* + (when (and ,start (mark< ,start *inc-pos*)) + ,start) + ,start)))))) + +(defMacro atom-start (start) + (let ((pos (gensym)) + (char (gensym)) + (buf-start (gensym))) + `(when ,start + (let ((,buf-start (buf-start-mark *buf*))) + (do* ((,pos ,start (mark-before ,pos)) + (,char (when (and ,pos (mark>= ,pos ,buf-start)) + (mark-char ,pos)) + (when (and ,pos (mark>= ,pos ,buf-start)) + (mark-char ,pos)))) + ((or (null ,char) ; *** + (whitespacep ,char) (char= ,char #\() + (char= ,char #\)) (char= ,char #\")) + (if ,pos (mark-after ,pos) ,buf-start))))))) + +(defMacro atom-end (s) + (let ((start (gensym)) + (buffer-end-mark (gensym)) + (pos (gensym)) + (char (gensym))) + `(when ,s + (let ((,start (clone ,s)) + (,buffer-end-mark (buffer-end-mark *buf*))) + (do* ((,pos ,start (mark-after ,pos)) + (,char (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos)) + (when (mark<= ,pos ,buffer-end-mark) (mark-char ,pos)))) + ((or (null ,char) ; *** + (whitespacep ,char) (char= ,char #\)) (char= ,char #\() + (char= ,char #\") (char= ,char #\;)) + ,pos)))))) + +(defun buffer-top-level-sexpr-start (buffer &optional storage) + (cond (storage + (set-storage storage (buffer-point buffer)) + (hemlock::top-level-offset storage -1)) + (t + (let ((mark (clone (buffer-point buffer)))) + (hemlock::top-level-offset mark -1))))) + +(defun buffer-top-level-sexpr-end (buffer &optional storage) + (cond (storage + (set-storage storage (buffer-point buffer)) + (hemlock::top-level-offset storage 1)) + (t + (let ((mark (clone (buffer-point buffer)))) + (hemlock::top-level-offset mark 1))))) + + +;;; ---------------------------------------------------------------------------- +;;; Miscellaneous functions and macros. +;;; ---------------------------------------------------------------------------- +;;; +(defun pattern-search (mark pattern &optional end) + (with-mark ((m mark)) + (if end + (when (and (find-pattern m pattern) (mark< m end)) m) + (when (find-pattern m pattern) m)))) + +#| +;;; (buffer-writable buffer) is broken +(defun writable-p (thing) + (declare (ignore thing)) + t) + +(defun writable-path-p (path) + (let* ((file-manager (#/defaultManager ns:ns-file-manager)) + (path (ccl::%make-nsstring path))) + (#/isWritableFileAtPath: file-manager path))) + +(defMethod writable-p ((hemlock-view hi::hemlock-view)) + (let ((buffer (hemlock-view-buffer hemlock-view))) + (or (not *style-case-p*) + (format t "~%view-writable-p: ~S" (buffer-writable buffer)) + ;; *** broken + (buffer-writable buffer)))) + +(defMethod writable-p ((text-view gui::hemlock-textstorage-text-view)) + (let* ((hemlock-view (gui::hemlock-view text-view)) + (buffer (hemlock-view-buffer hemlock-view))) + (or (not *style-case-p*) + (format t "~%writable-p: ~S" (buffer-writable buffer)) + (buffer-writable buffer)))) + +(defMethod writable-p ((window gui::hemlock-frame)) + (let* ((hemlock-view (gui::hemlock-view window)) + (buffer (hemlock-view-buffer hemlock-view))) + (or (not *style-case-p*) + (format t "~%writable-p: ~S" (buffer-writable buffer)) + (buffer-writable buffer)))) +|# + +(defun active-hemlock-window () + "Return the active hemlock-frame." + (gui::first-window-satisfying-predicate + #'(lambda (w) + (and (typep w 'gui::hemlock-frame) + (not (typep w 'gui::hemlock-listener-frame)) + (#/isKeyWindow w))))) + +(defun window-path (w) + "Return the window's path." + (let* ((pane (slot-value w 'gui::pane)) + (hemlock-view (when pane (gui::text-pane-hemlock-view pane))) + (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view)))) + (when buffer (hi::buffer-pathname buffer)))) + +(defmacro char-eolp (char) + `(member ,char '(#\return #\linefeed #\newline ,(code-char #x2028) ,(code-char #x2029)))) + +(defun ed-beep () (#_NSBeep)) ; *** this beeper doesn't beep + +(define-symbol-macro *listener-output* (hemlock-ext::top-listener-output-stream)) + +(defun listener-msg (string &rest args) + (apply 'format *listener-output* string args)) + +(defun selection-marks (text-view) + (let ((selection (#/selectedRange text-view)) + start end) + (when selection + (let ((length (ns:ns-range-length selection)) + (location (ns:ns-range-location selection))) + (unless (zerop length) + (setf start (move-to-absolute-position (buf-start-mark) location)) + (setf end (character-offset (clone start) length))))) + (values start end))) + +(defun key-event= (k1 k2) + (and (= (hi::key-event-keysym k1) (hi::key-event-keysym k2)) + (= (hi::key-event-bits k1) (hi::key-event-bits k2)))) + +(defmethod hemlock-update ((view hi:hemlock-view) start end &optional count) + (let* ((buffer (hemlock-view-buffer view)) + (document (hi::buffer-document buffer)) + (text-storage (if document (slot-value document 'gui::textstorage))) + (location (mark-absolute-position start)) + (length (or count (- (mark-absolute-position end) location)))) +; (count (hemlock::count-characters (region start end)))) + #+sax-debug (when *hemlock-update-debug* + (debug-out "~%~%~S" 'hemlock-update) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end) + (debug-out "~%location: ~S" location) + (debug-out "~%length: ~S" length)) + ;;; 0 is the fontnum + (gui::perform-edit-change-notification + text-storage + (objc:@selector #/noteHemlockAttrChangeAtPosition:length:) + location length 0))) + +(defmethod hemlock-update ((frame gui::hemlock-frame) start end &optional count) + (let ((hemlock-view (gui::hemlock-view frame))) + (hemlock-update hemlock-view start end count))) + +(defMacro attribute-dictionary (var) `(car ,var)) + +(defMacro style-case (var) `(cdr ,var)) + +(defun set-style-attributes (dictionary &optional (start (buf-start-mark)) + (end (buf-end-mark))) + #+sax-debug (when *set-style-attributes-debug* + (debug-out "~%~%~S" 'set-style-attributes) + (debug-out "~%dictionary: ~S" dictionary) + (debug-out "~%start: ~S" start) + (debug-out "~%end: ~S" end)) + + (ns:with-ns-range (range) + (let* ((location (mark-absolute-position start)) + (length (- (mark-absolute-position end) location))) + (setf (ns:ns-range-location range) location) + (setf (ns:ns-range-length range) length) + ;; Remove all temporary attributes from the character range + (#/removeTemporaryAttribute:forCharacterRange: + *layout* #&NSForegroundColorAttributeName range) + (#/removeTemporaryAttribute:forCharacterRange: + *layout* #&NSUnderlineStyleAttributeName range) + (#/addTemporaryAttributes:forCharacterRange: *layout* dictionary range)))) + +(defun set-generic-text-style (text-view &optional (start (buf-start-mark)) (end (buf-end-mark))) + ;; eliminate paren highlighting: + (let* ((begin (mark-absolute-position start)) + (count (- (mark-absolute-position end) begin))) + (when (and begin count) + (ns:with-ns-range (char-range begin count) + (let* ((layout (#/layoutManager text-view))) + (#/removeTemporaryAttribute:forCharacterRange: + layout #&NSBackgroundColorAttributeName + char-range))))) + ;; *** maybe chuck this: + (set-style-attributes (attribute-dictionary *generic-text-style*) start end)) + +(defun downcase-region (start end) + ;; downcases all nonescaped characters in region + (filter-region #'string-downcase (region start end))) + +(defun upcase-region (start end) + (filter-region #'string-upcase (region start end))) + +(defun capitalize-region (start end) + (filter-region #'string-capitalize (region start end))) + +(defMethod set-style-case ((case (eql :down)) start end) + (downcase-region start end)) + +(defMethod set-style-case ((case (eql :up)) start end) + ;; don't use eupcase region... + (upcase-region start end)) + +(defMethod set-style-case ((case (eql :unchanged)) start end) + (declare (ignore start end)) ()) + +(defMethod set-style-case ((case (eql :cap)) start end) + (capitalize-region start end)) + +(defMethod set-style-case ((case (eql :cap3)) start end) + (set-style-case :down start end) + (capitalize-region (mark-offset start 3) (mark-offset start 4))) + +(defMethod set-style-case ((case (eql :cap03)) start end) + (set-style-case :down start end) + (capitalize-region start end) + (capitalize-region (mark-offset start 3) (mark-offset start 4))) + +(defMethod set-style-case ((case (eql :cap8)) start end) + (set-style-case :down start end) + (capitalize-region (mark-offset start 8) (mark-offset start 9))) + +(defMethod set-style-case ((case (eql :cap12)) start end) + (set-style-case :down start end) + (capitalize-region (mark-offset start 12) (mark-offset start 13))) + +(defMacro style-region (style start end &optional (set-case-p t)) + "This is the basic styling macro that calls SET-STYLE-ATTRIBUTES and SET-STYLE-CASE." + `(progn + #+sax-debug (when *style-region-debug* + (debug-out "~%~%~S" 'style-region) + (debug-out "~%start: ~S" ,start) + (debug-out "~%end: ~S" ,end) + (debug-out "~%style: ~S" ,style) + (debug-out "~%set-case-p: ~S" ,set-case-p) + (debug-out "~%*paste-p*: ~S" *paste-p*) + (debug-out "~%*paste-start*: ~S" *paste-start*) + (debug-out "~%*paste-end*: ~S" *paste-end*) + (debug-out "~%*inc-p*: ~S" *inc-p*) + (debug-out "~%*inc-pos*: ~S" *inc-pos*)) + (when (or (and *inc-p* (not *paste-p*) + (mark>= *inc-pos* ,start) + (mark<= *inc-pos* ,end)) + (not *inc-p*) + (and *paste-p* + (mark>= ,start *paste-start*) + (mark<= ,end *paste-end*))) + + (when (and *style-case-p* ,set-case-p (style-case ,style)) + #+sax-debug (when *style-region-debug* + (debug-out "~%set-style-case, case: ~S" (style-case ,style)) + (debug-out "~%set-style-case, region: ~S" (region ,start ,end))) + (set-style-case (style-case ,style) ,start ,end)) + + (cond ((and *inc-p* (not *paste-p*)) + ;; Don't set attributes when doing incremental. We are + ;; inside #/beginEditing, #/endEditing. Save the values. + #+sax-debug (when *style-region-debug* + (debug-out "~%~%*** setting *form-style* for: ~S ***" + (region-to-string (region ,start ,end)))) + (setq *form-style* ,style + *form-start* ,start + *form-end* ,end)) + (t + #+sax-debug (when *style-region-debug* + (if (equalp ,style *generic-text-style*) + (debug-out "~%*** styling-region-generically: ~S ***" + (region-to-string (region ,start ,end))) + (debug-out "~%*** styling-region: ~S ***" + (region-to-string (region ,start ,end)))) + (debug-out "~%style: ~S" ,style)) + (set-style-attributes (attribute-dictionary ,style) ,start ,end)))))) + + Index: /release/1.4/source/contrib/foy/syntax-styling/syntax-styling.lisp =================================================================== --- /release/1.4/source/contrib/foy/syntax-styling/syntax-styling.lisp (revision 13073) +++ /release/1.4/source/contrib/foy/syntax-styling/syntax-styling.lisp (revision 13073) @@ -0,0 +1,29 @@ + +;;; syntax-styling.lisp + +(in-package :common-lisp-user) + +;;; (pushnew :sax-debug *features*) + +(unless (member "SYNTAX-STYLING" *modules* :test #'string-equal) + (eval-when (:load-toplevel :execute) + (defParameter *syntax-styling-directory* + (make-pathname :name nil :type nil :defaults (if *load-pathname* + *load-pathname* + *loading-file-source-file*))) + (defParameter *syntax-styling-files* + (list #+sax-debug (merge-pathnames ";testing-specials.lisp" *syntax-styling-directory*) + (merge-pathnames ";syntax-styling-specials.lisp" *syntax-styling-directory*) + (merge-pathnames ";syntax-styling-comments.lisp" *syntax-styling-directory*) + (merge-pathnames ";syntax-styling-1.lisp" *syntax-styling-directory*) + (merge-pathnames ";syntax-styling-2.lisp" *syntax-styling-directory*) + #+sax-debug (merge-pathnames ";testing1.lisp" *syntax-styling-directory*) + #+sax-debug (merge-pathnames ";testing2.lisp" *syntax-styling-directory*) + ))) + +(dolist (file *syntax-styling-files*) + (load file)) + +(provide :syntax-styling) + +) Index: /release/1.4/source/contrib/foy/window-parking-cm/window-parking.lisp =================================================================== --- /release/1.4/source/contrib/foy/window-parking-cm/window-parking.lisp (revision 13072) +++ /release/1.4/source/contrib/foy/window-parking-cm/window-parking.lisp (revision 13073) @@ -29,4 +29,5 @@ (defparameter *window-parker* nil "The window-parker instance.") (defparameter *window-parking-menu* nil "The window-parking-menu instance.") +(defParameter *park-p* t "To park or not to park.") ;;; ---------------------------------------------------------------------------- @@ -246,5 +247,11 @@ (ns:with-ns-rect (r (ps-h-position ps) (ps-v-position ps) (ps-h-dimension ps) (ps-v-dimension ps)) (#/setFrame:display: window r t)) - (#/makeKeyAndOrderFront: window nil))) + (#/makeKeyAndOrderFront: window nil)) + (let ((style-screen-function (find-symbol "STYLE-SCREEN" (find-package :sax)))) + (when style-screen-function + (let* ((hemlock-view (gui::hemlock-view window)) + (text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view)))) + (when text-view + (funcall style-screen-function text-view)))))) ;;; ---------------------------------------------------------------------------- @@ -260,5 +267,5 @@ (defMethod park ((wp window-parker) (window parkable-hemlock-frame)) - (when (wp-parking-spots wp) + (when (and (wp-parking-spots wp) *park-p*) ;; Already parked? (let* ((position (position window (wp-parking-spots wp) :key #'ps-tenant)) @@ -372,29 +379,30 @@ ;;; unless the parking-spot is not on screen or the window is already in that location. (defMethod move-window-to-position ((wp window-parker) window function-key) - (let* ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key)) - (tenant (when parking-spot (ps-tenant parking-spot)))) - (cond ((and parking-spot (parking-spot-on-screen-p parking-spot window)) - (cond (tenant - (cond ((eql window tenant) - (cmenu:echo-msg "Already in parking-spot ~a." function-key)) - (t - (cond ((modified-p tenant) - (cmenu:notify (format nil "First save: ~S. Then try again." - (cmenu:window-path tenant))) - (init-parking tenant)) - (t - (vacate-current-location wp window) - (bump-location-and-set-location-values wp parking-spot window) - (#/makeKeyAndOrderFront: window nil) - (cmenu:echo-msg "Moved to parking-spot ~a." function-key)))))) - (t - (vacate-current-location wp window) - (apply-parking-spot-values parking-spot window) - (#/makeKeyAndOrderFront: window nil) - (cmenu:echo-msg "Moved to parking-spot ~a." function-key)))) - (t - (if (null parking-spot) - (cmenu:notify (format nil "Parking-spot ~a is not defined." function-key)) - (cmenu:notify (format nil "Parking-spot ~a is off screen." function-key))))))) + (when *park-p* + (let* ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key)) + (tenant (when parking-spot (ps-tenant parking-spot)))) + (cond ((and parking-spot (parking-spot-on-screen-p parking-spot window)) + (cond (tenant + (cond ((eql window tenant) + (cmenu:echo-msg "Already in parking-spot ~a." function-key)) + (t + (cond ((modified-p tenant) + (cmenu:notify (format nil "First save: ~S. Then try again." + (cmenu:window-path tenant))) + (init-parking tenant)) + (t + (vacate-current-location wp window) + (bump-location-and-set-location-values wp parking-spot window) + (#/makeKeyAndOrderFront: window nil) + (cmenu:echo-msg "Moved to parking-spot ~a." function-key)))))) + (t + (vacate-current-location wp window) + (apply-parking-spot-values parking-spot window) + (#/makeKeyAndOrderFront: window nil) + (cmenu:echo-msg "Moved to parking-spot ~a." function-key)))) + (t + (if (null parking-spot) + (cmenu:notify (format nil "Parking-spot ~a is not defined." function-key)) + (cmenu:notify (format nil "Parking-spot ~a is off screen." function-key)))))))) ;;; ---------------------------------------------------------------------------- Index: /release/1.4/source/lisp-kernel/darwinx8632/Makefile =================================================================== --- /release/1.4/source/lisp-kernel/darwinx8632/Makefile (revision 13072) +++ /release/1.4/source/lisp-kernel/darwinx8632/Makefile (revision 13073) @@ -70,5 +70,5 @@ OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) -../../dx86cl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile +../../dx86cl: tiger-sdk-check $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) @@ -95,2 +95,8 @@ strip -s retain ../../dx86cl +.PHONY: tiger-sdk-check +tiger-sdk-check: + @test -d /Developer/SDKs/MacOSX10.4u.sdk || \ + (echo "*** Install Xcode 10.4 support"; exit 1) + + Index: /release/1.4/source/lisp-kernel/darwinx8664/Makefile =================================================================== --- /release/1.4/source/lisp-kernel/darwinx8664/Makefile (revision 13072) +++ /release/1.4/source/lisp-kernel/darwinx8664/Makefile (revision 13073) @@ -93,5 +93,5 @@ OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) -../../dx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile +../../dx86cl64: tiger-sdk-check $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) @@ -115,2 +115,8 @@ strip: ../../dx86cl64 strip -s retain ../../dx86cl64 + +.PHONY: tiger-sdk-check +tiger-sdk-check: + @test -d /Developer/SDKs/MacOSX10.4u.sdk || \ + (echo "*** Install Xcode 10.4 support"; exit 1) +