301 lines
10 KiB
Plaintext
301 lines
10 KiB
Plaintext
;;;; f o n t - l o c k . s t k -- A simple syntax high-lighter
|
|
;;;;
|
|
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 29-Oct-1998 18:51
|
|
;;;; Last file update: 3-Sep-1999 19:51 (eg)
|
|
|
|
;; This package is a extra light version of the Emacs font-lock package
|
|
;; (specialized for Scheme)
|
|
;; It is a little bit slow and it is has some "bugs":
|
|
;; - Multi-lines comments are not correctly handled (because the
|
|
;; Tk text widget works line by line
|
|
;; - Regexps are very simplistic and not correct in all circumstances
|
|
;; - There is no way to customize the font-lock colors
|
|
;;
|
|
;; Any help to improve this package will be greatly appreciated
|
|
|
|
|
|
;;;
|
|
;;; Variables which which can be overloaded by the user file ~/.stkvars
|
|
;;;
|
|
(define-module STk
|
|
(define *fontify-keyword-color* "Green4")
|
|
(define *fontify-class-color* "Blue")
|
|
(define *fontify-syntax-color* "Purple3")
|
|
(define *fontify-comment-color* "Red")
|
|
(define *fontify-string-color* "IndianRed"))
|
|
|
|
;;;
|
|
;;; The rest of the file is in the Tk module
|
|
;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;=============================================================================
|
|
;
|
|
; Global variables
|
|
;
|
|
;=============================================================================
|
|
(define *fontify-count* 0)
|
|
(define *fontify-idle* #t)
|
|
|
|
|
|
;;; Regexps for various think that we want "font-lockify". This is a list whose
|
|
;;; first element is the regexp and the second element is an offset
|
|
(define *fontify-keyword-regexp* (list "(^|[ \t]+):[0-9a-zA-Z_-]+" 0))
|
|
(define *fontify-comment-regexp* (list "(#!|;).*$|#\\|.*\\|#" 0))
|
|
(define *fontify-string-regexp* (list "\"([^\\\"]|\\\\.)*\"" 0))
|
|
(define *fontify-class-regexp* (list "<[^>]*>" 0))
|
|
(define *fontify-syntax-regexp* (list "\\((lambda|if|else|define(-macro|-generic|-method|-class)*|begin|case|cond|while|do|when|unless|set!|let(\\*|rec)*) "
|
|
1))
|
|
|
|
(define *fontify-syntax* '(lambda if else define define-macro define-generic
|
|
define-class begin case cond while do when
|
|
unless set let let* letrec))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; make-fontifiable
|
|
; Transforms a text widget in a widget able to do Scheme fontification
|
|
;
|
|
;=============================================================================
|
|
(define (make-fontifiable txt)
|
|
;; Creates tags for strings keywords comments. ORDER IS IMPORTANT!!!
|
|
(for-each (lambda (x)
|
|
(let ((name (car x))
|
|
(fg (cadr x)))
|
|
(txt 'tag 'configure name :foreground fg)))
|
|
(list
|
|
(list "keyword_tag" *fontify-keyword-color*)
|
|
(list "class_tag" *fontify-class-color*)
|
|
(list "syntax_tag" *fontify-syntax-color*)
|
|
(list "comment_tag" *fontify-comment-color*)
|
|
(list "string_tag" *fontify-string-color*)))
|
|
|
|
;; Define a mark which states where is the beginning of the region to font-lock
|
|
(txt 'mark 'set "start_fontify" "insert")
|
|
(txt 'mark 'gravity "start_fontify" 'left)
|
|
|
|
;; Change text bindings such that entering a new character triggers fontify
|
|
;; This is done by changing the "bindtags" of the text
|
|
(let* ((order (bindtags txt))
|
|
(text (member "Text" order))
|
|
(when-move (gensym "when-move")))
|
|
|
|
(when text
|
|
(set-cdr! text (cons "ScmTxt" (cdr text)))
|
|
(bindtags txt (cons when-move order)))
|
|
(bind when-move "<Tab>" (lambda (|W|) (reindent-line |W|) 'break))
|
|
(bind when-move "<Any-KeyPress>" (lambda (|W|) (idle-fontify |W|)))
|
|
(bind when-move "<Any-ButtonPress>" (lambda (|W|) (idle-fontify |W|))))
|
|
|
|
(bind "ScmTxt" "<Any-KeyPress>" (lambda (|W|)
|
|
(flash-delete-tags |W|)
|
|
(fontify-line |W| "insert")))
|
|
(for-each (lambda (x)
|
|
(bind "ScmTxt" x (lambda(|W|)
|
|
(fontify-buffer |W| "start_fontify"))))
|
|
'("<<Paste>>" "<ButtonRelease-2>" "<Control-l>"))
|
|
(bind "ScmTxt" ")" (lambda (|W|) (flash-paren |W| "(" ")")))
|
|
(bind "ScmTxt" "]" (lambda (|W|) (flash-paren |W| "[" "]")))
|
|
|
|
)
|
|
|
|
;=============================================================================
|
|
;
|
|
; Fontify functions
|
|
;
|
|
;=============================================================================
|
|
(define (fontify-line t pos)
|
|
|
|
(define (fontify-regexp regexp offset tag from to)
|
|
;; Search for all instances of a given regexp in a text widget and
|
|
;; apply a given tag to each instance found.
|
|
(t 'tag 'remove tag from to)
|
|
(let Loop ((start from))
|
|
(let ((cur (t 'search :regexp :count '*fontify-count*
|
|
;;;;FIXME: :env (module-environment (current-module))
|
|
regexp start to)))
|
|
(when cur
|
|
(let ((cur (cons (car cur) (+ (cdr cur) offset)))
|
|
(last (cons (car cur) (- (+ (cdr cur) *fontify-count*) offset))))
|
|
(t 'tag 'add tag cur last)
|
|
(loop last))))))
|
|
|
|
(let* ((start (t 'index (format #f "~A linestart" pos)))
|
|
(end (t 'index (format #f "~A lineend" pos)))
|
|
(do-font (lambda (rgxp tag)
|
|
(fontify-regexp (car rgxp) (cadr rgxp) tag start end))))
|
|
|
|
;; Eventually correct the start position
|
|
(if (t 'compare start "<" "start_fontify") (set! start "start_fontify"))
|
|
|
|
(do-font *fontify-keyword-regexp* "keyword_tag")
|
|
(do-font *fontify-class-regexp* "class_tag")
|
|
(do-font *fontify-syntax-regexp* "syntax_tag")
|
|
(do-font *fontify-string-regexp* "string_tag")
|
|
(do-font *fontify-comment-regexp* "comment_tag")))
|
|
|
|
(define (fontify-buffer t from-line)
|
|
(when *fontify-idle*
|
|
(set! *fontify-idle* #f)
|
|
(let ((start (car (t 'index from-line)))
|
|
(end (car (t 'index "end"))))
|
|
(let Loop ((line start))
|
|
(fontify-line t (cons line 0))
|
|
(after 'idle (lambda () (if (< line end) (Loop (+ line 1)))))))
|
|
(set! *fontify-idle* #t)))
|
|
|
|
|
|
(define (fontify-whole-buffer t)
|
|
(fontify-buffer t "1.0"))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; Flashing parenthesis
|
|
;
|
|
;=============================================================================
|
|
|
|
(define (flash-delete-tags txt)
|
|
(txt 'tag 'delete "fontify_flash")
|
|
(txt 'tag 'delete "fontify_bad_flash"))
|
|
|
|
(define (flash-paren txt open close)
|
|
;; Erase the current flashing parent and create a new tag for this one
|
|
(flash-delete-tags txt)
|
|
(txt 'tag 'conf "fontify_flash" :background "green")
|
|
|
|
;; Search the opening parenthesis
|
|
(let Loop ((depth 0) (count -2))
|
|
(let* ((pos (txt 'index (format #f "insert ~Ac" count)))
|
|
(char (txt 'get pos)))
|
|
(cond
|
|
((txt 'compare pos "<=" "start_fontify")
|
|
(if (and (string=? char open) (zero? depth))
|
|
(txt 'tag 'add "fontify_flash" pos)
|
|
(begin
|
|
;; create a tag to signal the bad match
|
|
(txt 'tag 'conf "fontify_bad_flash" :background "red")
|
|
(txt 'tag 'add "fontify_bad_flash" "insert-1c"))))
|
|
((string=? char close) (Loop (- depth 1) (- count 1)))
|
|
((string=? char open) (if (zero? depth)
|
|
(txt 'tag 'add "fontify_flash" pos)
|
|
(Loop (+ depth 1) (- count 1))))
|
|
(else (Loop depth (- count 1)))))))
|
|
|
|
(define (idle-fontify txt)
|
|
(after 'idle
|
|
(lambda ()
|
|
; fontify current line
|
|
(fontify-line txt "insert")
|
|
; see if we have an opening parenthesis to flash
|
|
(flash-delete-tags txt)
|
|
(let ((cur (txt 'get "insert-1c")))
|
|
(cond
|
|
((string=? cur ")") (flash-paren txt "(" ")"))
|
|
((string=? cur "]") (flash-paren txt "[" "]"))))
|
|
; if the text has a idle-hook associated execute it
|
|
(let ((hook (get-widget-property txt :idle-hook #f)))
|
|
(if hook (hook))))))
|
|
|
|
;=============================================================================
|
|
;
|
|
; font-lock-indent
|
|
;
|
|
; This is not really fontification. Anyway this so close ...
|
|
;=============================================================================
|
|
|
|
(define (how-much-spaces line) ; find the amount of spaces needed for next line
|
|
(let ((len (string-length line))
|
|
(spc 0))
|
|
|
|
;; Find the number of leading spaces
|
|
(let Loop ((i 0))
|
|
(if (and (< i len) (memv (string-ref line i) '(#\space #\tab)))
|
|
(Loop (+ i 1))
|
|
(set! spc i)))
|
|
|
|
;; Find te position of last open parenthesis (which is not closed)
|
|
(let Loop ((i spc) (stack '()))
|
|
(if (< i len)
|
|
(case (string-ref line i)
|
|
((#\( #\[) (Loop (+ i 1) (cons i stack)))
|
|
((#\) #\]) (Loop (+ i 1) (if (null? stack) stack (cdr stack))))
|
|
(else (Loop (+ i 1) stack)))
|
|
;; string exhausted
|
|
(unless (null? stack)
|
|
(let* ((pos (+ (car stack) 1))
|
|
(s (substring line pos len))
|
|
(first #f))
|
|
;; See if the first word the substring is a symbol
|
|
(catch (set! first (read-from-string s)))
|
|
(if (symbol? first)
|
|
; car of the list is a symbol
|
|
(if (memv first *fontify-syntax*)
|
|
;; We have syntax. Do a small indent
|
|
(set! spc (+ pos 2))
|
|
;; Not syntax. Find the first non space after it
|
|
(let Loop
|
|
((i (+ pos (string-length (symbol->string first)))))
|
|
(if (and (< i len)
|
|
(memv (string-ref line i) '(#\space #\tab)))
|
|
(Loop (+ i 1))
|
|
(set! spc i))))
|
|
;; Not a symbol. Indent just after the parenthesis
|
|
(set! spc pos))))))
|
|
spc))
|
|
|
|
|
|
(define (font-lock-indent txt tag) ;; tag is the tag associated to inserted spaces
|
|
(let* ((pos (if (txt 'compare "insert linestart -1l" "<" "start_fontify linest")
|
|
"start_fontify linestart"
|
|
"insert linestart -1 l"))
|
|
(line (txt 'get pos "insert-1l lineend"))
|
|
(spc (how-much-spaces line)))
|
|
(txt 'insert "insert" (make-string spc #\space) tag)))
|
|
|
|
|
|
(define (find-previous-sexpr txt)
|
|
(let ((pos (txt 'tag 'ranges "fontify_flash")))
|
|
(if (= (length pos) 2)
|
|
(txt 'get (car pos) "insert")
|
|
#f)))
|
|
|
|
(define (reindent-line txt)
|
|
|
|
(define (trim l)
|
|
(let Loop ((pos 0)
|
|
(max (string-length l)))
|
|
(if (or (>= pos max)
|
|
(not (memv (string-ref l pos) '(#\space #\tab))))
|
|
(substring l pos max)
|
|
(Loop (+ pos 1) max))))
|
|
|
|
(let* ((line (txt 'get "insert linestart" "insert lineend"))
|
|
(tline (trim line)))
|
|
(txt 'delete "insert linestart" "insert lineend")
|
|
(font-lock-indent txt "")
|
|
(txt 'insert "insert" tline)))
|
|
|
|
(provide "font-lock")
|
|
;======================================================================
|
|
|
|
#|
|
|
(pack (text '.t) :expand #t :fill "both")
|
|
|
|
(make-fontifiable .t)
|
|
|#
|