* Backus-Naur major mode.
@ 2009-11-04 14:39 Alin Soare
0 siblings, 0 replies; only message in thread
From: Alin Soare @ 2009-11-04 14:39 UTC (permalink / raw)
To: Emacs Dev [emacs-devel]
[-- Attachment #1.1: Type: text/plain, Size: 847 bytes --]
I did write for me a major mode for writing grammars in Backus-Naur
notation.
I send you the code of the Backus-Naur mode.
If you consider that this code would be useful for emacs, I will send
improved versions.
I attach here a grammar file for testing it.
The font lock of the right nonterminals is chaged while typing.
A few key binding :
C-x SPC jumps to the definition of the right-nonterminal under the cursor.
mouse-3 jumps to the definition of the clicked right-nonterminal .
M-s rotate the cursor to all the matches of the left-nonterminal under the
cursor.
C-u C-SPC can be used, because every jump adds a mark.
Note that I do not parse for myself in yacc notation: `;' between right
symbols, `|' for another rule, etc.
I parse using a rule on every line, and all the symbols of a rule are
separated by simple spaces.
Alin.
[-- Attachment #1.2: Type: text/html, Size: 953 bytes --]
[-- Attachment #2: gram-test --]
[-- Type: application/octet-stream, Size: 1334 bytes --]
dec:
dec-sp init-de-list.opt `;'
dec-sp:
storage-class-sp dec-sp.opt
t-sp dec-sp.opt
t-q dec-sp.opt
f-sp dec-sp.opt
init-fee-list:
init-fee
init-fee-list `,' init-fee
init-fee:
fee
fee `=' initializer
initializer:
% Constraints
% A dec-sp ... is jumped over here
s-c-sp:
`t'
`ex'
`s'
`a'
`re'
% Declataror
fee:
pointer.opt d-fee
d-fee:
id
`(' fee `)'
d-fee `[' t-q-list.opt a-exp.opt `]'
d-fee `[' `s' t-q-list.opt a-exp `]'
d-fee `[' t-q-list `s' a-exp `]'
d-fee `[' t-q-list.opt `*' `]'
d-fee `(' pa-t-list `)'
d-fee `(' id-list.opt `)'
pointer:
`*' t-q-list.opt
`*' t-q-list.opt pointer
t-q-list:
t-q
t-q-list t-q
pa-t-list:
pa-list
pa-list `,' `...'
pa-list:
pa-dec
pa-list `,' pa-dec
pa-dec:
dec-sp fee
dec-sp abs-fee.opt
id-list:
id
id-list `,' id
t-na:
id
id:
id-nond
id id-nond
id d
id-nond:
nond
u-ch-name
other chs
nond:
`_' `a' `b' `c' `d' `e' `f' `g' `h' `i' `j' `k' `l' `m'
`n' `o' `p' `q' `r' `s' `t' `u' `v' `w' `x' `y' `z'
`A' `B' `C' `D' `E' `F' `G' `H' `I' `J' `K' `L' `M'
`N' `O' `P' `Q' `R' `S' `T' `U' `V' `W' `X' `Y' `Z'
d:
`0' `1' `2' `3' `4' `5' `6' `7' `8' `9'
u-ch-name:
`\u' hex-quad
`\U' hex-quad hex-quad
hex-quad:
hex-d hex-d
hex-d hex-d
hex-d:
`0' `1' `2' `3' `4' `5' `6' `7' `8' `9'
`a' `b' `c' `d' `e' `f'
`A' `B' `C' `D' `E' `F'
[-- Attachment #3: bn-mode.el --]
[-- Type: application/octet-stream, Size: 17297 bytes --]
(defvar bn-left-nonterminal-definition
"^\\([A-Za-z-]*\\)\\(:\\)[ ]\\{0,3\\}$"
"The regular expression that marks the left side from the \
definition of a rule" )
(defvar bn-left-nonterminal-list nil
"keeps the list of all the left nonterminals. this could be
defined locally only, inside
bn-timer-font-lock-right-nonterminals. not used.")
(defvar bn-timer-var nil
"non nil means that a fontification will follow")
(defvar bn-comment-char "%" )
(defvar after-change-functions nil )
(define-derived-mode
bn-mode
fundamental-mode
"Backus-Naur"
"A major mode for well writing grammars in Backus-Naur form."
(make-local-variable 'bn-comment-char)
(make-local-variable 'bn-overlays)
(make-local-variable 'bn-iterator)
;;(add-hook 'after-change-functions 'bn-change t)
(make-local-variable 'after-change-functions)
(make-local-variable 'bn-left-nonterminal-list)
(make-local-variable 'bn-rotate-around-left-nonterminal-match-ring)
(setq font-lock-defaults
(list
(list
(list
bn-left-nonterminal-definition
'(1 'bn-left-nonterminal-definition-font )
'(2 'bn-left-nonterminal-definition-closure ) )
'( "\\(`\\)\\([[:graph:]]*\\)\\('\\)"
(1 'bn-terminal-closure )
(2 'bn-terminal-definition )
(3 'bn-terminal-closure )
)
(list
(concat "^\\(" bn-comment-char "\\)\\(.*\\)" )
'(1 'bn-comment-sign )
'(2 'bn-commented-text ) ) )
t ) )
(bn-stop-timer)
(remove-overlays)
(setq after-change-functions (add-to-list 'after-change-functions 'bn-change) )
(local-set-key [tab] 'backus-naur-indent)
(local-set-key [home]
(lambda nil (interactive)
(if (equal (char-before) ?\n)
(bn-beginning-of-defun)
(beginning-of-line) ) ) )
(local-set-key [end]
(lambda nil (interactive)
(if (equal (char-after) ?\n)
(bn-end-of-defun)
(end-of-line) ) ) )
(bn-timer-font-lock-right-nonterminals)
(local-set-key "\M-s" 'bn-search )
(local-set-key (kbd "C-x SPC")
(lambda () (interactive "")
"jump to the definition of the nonterminal under the cursor. "
(let* ((type (get-text-property (point) 'type))
(nonterminal
(and type
(get-text-property (point) 'nonterminal) ) )
(p
(and nonterminal
(get-text-property (point) 'position) ) ) )
(cond
( (eq type 'right)
(and p
(bn-jump p )
(recenter)
(message "jump to `%s' %s" nonterminal p ) ) )
((eq type 'left)
(error "`%s' is a left nonterminal\n" nonterminal ) ) ) ) ) ) )
(defun bn-jump (p)
(push-mark)
(goto-char p) )
(defun bn-stop-timer ()
"stop the timer for fontification"
(and bn-timer-var
(progn
(cancel-timer bn-timer-var)
(setq bn-timer-var nil) ) ) )
(defface bn-left-nonterminal-definition-font
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "red"))
(((class color) (min-colors 88) (background dark)) (:foreground "orange red"))
(((class color) (min-colors 16) (background light)) (:foreground "orange"))
(((class color) (min-colors 16) (background dark)) (:foreground "gold"))
(((class color) (min-colors 8)) (:foreground "dark orange"))
(t (:weight bold :underline t)))
"font used for left nonterminals." )
(defface bn-right-nonterminal-definition-font
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "AntiqueWhite2"))
(((class color) (min-colors 88) (background dark)) (:foreground "DarkGoldenrod2"))
(((class color) (min-colors 16) (background light)) (:foreground "LightSteelBlue1"))
(((class color) (min-colors 16) (background dark)) (:foreground "burlywood2"))
(((class color) (min-colors 8)) (:foreground "PaleGreen2"))
(t (:weight bold :underline t)))
"font used for right nonterminals." )
(defface bn-left-nonterminal-definition-closure
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "deep sky blue"))
(((class color) (min-colors 88) (background dark)) (:foreground "spring green"))
(((class color) (min-colors 16) (background light)) (:foreground "dark sea green"))
(((class color) (min-colors 16) (background dark)) (:foreground "yellow green"))
(((class color) (min-colors 8)) (:foreground "olive drab"))
(t (:weight bold :underline t)))
"font used for the character `:' at the end of a left nonterminal." )
(defface bn-terminal-definition
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "cyan"))
(((class color) (min-colors 88) (background dark)) (:foreground "deep sky blue"))
(((class color) (min-colors 16) (background light)) (:foreground "medium spring green"))
(((class color) (min-colors 16) (background dark)) (:foreground "spring green"))
(((class color) (min-colors 8)) (:foreground "medium blue"))
(t (:weight bold :underline t)))
"font used for terminals." )
(defface bn-terminal-closure
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "light sea green"))
(((class color) (min-colors 88) (background dark)) (:foreground "yellow"))
(((class color) (min-colors 16) (background light)) (:foreground "medium sea green"))
(((class color) (min-colors 16) (background dark)) (:foreground "dark sea green"))
(((class color) (min-colors 8)) (:foreground "pale green"))
(t (:weight bold :underline t)))
"font used for the characters \` and \' around a terminal." )
(defface bn-search-rotate-face
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "chartreuse1"))
(((class color) (min-colors 88) (background dark)) (:foreground "chartreuse2"))
(((class color) (min-colors 16) (background light)) (:foreground "chartreuse3"))
(((class color) (min-colors 16) (background dark)) (:foreground "chartreuse4"))
(((class color) (min-colors 8)) (:foreground "SpringGreen4"))
(t (:weight bold :underline t)))
"font used for matched right nonterminals." )
(defface bn-commented-text
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "green4"))
(((class color) (min-colors 88) (background dark)) (:foreground "chartreuse"))
(((class color) (min-colors 16) (background light)) (:foreground "light coral"))
(((class color) (min-colors 16) (background dark)) (:foreground "firebrick"))
(((class color) (min-colors 8)) (:foreground "lawn green"))
(t (:weight bold :underline t)))
"font used for the text on a commented line" )
(defface bn-comment-sign
'((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
(((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
(((class color) (min-colors 88) (background light)) (:foreground "indian red"))
(((class color) (min-colors 88) (background dark)) (:foreground "lightgreen"))
(((class color) (min-colors 16) (background light)) (:foreground "tomato"))
(((class color) (min-colors 16) (background dark)) (:foreground "dark violet"))
(((class color) (min-colors 8)) (:foreground "sienna"))
(t (:weight bold :underline t)))
"font used for the character that comments a line" )
(defun backus-naur-indent ()
" The lines that contain a left nonterminal are indented from
0. These are the lines that match the regular expression
`bn-left-nonterminal-definition'.
The blank lines are cleared.
The lines which contain a rule are indented with a tab."
(interactive)
(let (
;; initial point
(cc (current-column))
;; end of line
(eol (prog2
(move-end-of-line nil)
(current-column) ) )
;; beginning of line
(bol (prog2
(move-beginning-of-line nil)
(current-column) ) )
;; beginning of text
(bot (prog2
(skip-chars-forward "[:blank:]")
(current-column) ) ) )
(cond
;; empty line
((equal eol bol)
t)
;; lines with blanks
((eq bot eol)
(move-beginning-of-line nil)
(just-one-space 0) )
;; line containing a left nonterminal
((save-excursion
(move-to-column eol)
(and (> (current-column) 3)
(search-backward ":" (- (point) 3) t ) ) )
(move-to-column bol)
(just-one-space 0) )
;; for the rest... add a tab at the beginning of the line
( (save-excursion
(move-beginning-of-line nil)
(not (search-forward-regexp "\t[^[:blank:]]" (+ 2 (point) ) t ) ) )
(just-one-space 0)
(insert-char ?\t 1)
(skip-chars-forward "[:blank:]") ) )
;; if the cursor was before the indetation inside the word, keep
;; it on the same position; if the initial position of the cursor
;; was before the word, move it at the beginning of the word
(move-to-column (+ (current-column)
(max 0 (- cc bot) ) ) ) ) )
(defun bn-commented-line-p ()
"return t when the point is inside a commented line, and nil
otherwise."
(equal
(save-excursion
(beginning-of-line)
(following-char) )
(elt bn-comment-char 0 ) ) )
(defun bn-timer-font-lock-right-nonterminals ()
"called after every buffer change to re-fontify the text."
(bn-stop-timer)
(save-excursion
(let (list-of-left-nonterminals
(map-right-nonterminal (make-sparse-keymap) )
(map-left-nonterminal (make-sparse-keymap) )
;; font lock properties modify the buffer, so this hook is
;; called recursively. temporarly after-change-functions
;; must be nil.
after-change-functions
;; changing the properties, one changes the modified status
(buffer-modified-flag (buffer-modified-p) )
;; this is equalent in this case to setting
;; after-change-functions to nil. However, we keep both
(inhibit-modification-hooks t)
;; make a temporary copy of the undo
;; list. add-text-properties adds information in the undo
;; list, even if in this case it shouldn't
(ul buffer-undo-list) )
;; we disable the undo information temporarly, because changing
;; the fontification is added by default in the undo list.
(buffer-disable-undo)
(define-key map-right-nonterminal [mouse-3]
(lambda (event) (interactive "e")
"jump to a left terminal definition"
(let ((p (get-text-property
(cadr (cadr event) )
'position) ) )
(and p
(bn-jump p )
(recenter)
(message (format "%s" p ) ) ) ) ) )
(define-key map-left-nonterminal "\M-s" 'bn-search )
(goto-char (point-min) )
;; make the list of left nonterminals out
(while (search-forward-regexp bn-left-nonterminal-definition nil t)
(push (cons (substring-no-properties (match-string 1) )
(match-beginning 1) )
list-of-left-nonterminals ) )
;; clean the previous fontification
(remove-text-properties
(point-min) (point-max)
'(mouse-face highlight font-lock-face keymap position) )
(setq bn-left-nonterminal-list nil)
;; scan the buffer to find the positions where every
;; left-nonterminal appears in the rules
(dolist (m list-of-left-nonterminals)
(let ( (match-positions) )
(goto-char (point-min) )
(while
(and (search-forward-regexp
(concat "[\t ]" "\\(" (car m) "\\)" "[\n .\t]") nil t)
(goto-char (1- (point) ) ) )
(and
;; if a right nonterminal is found, add it to the
;; matching list, subject to not being on a commented line
(not (bn-commented-line-p) )
(add-text-properties
(match-beginning 1)
(match-end 1)
(list 'mouse-face 'highlight
'font-lock-face 'bn-right-nonterminal-definition-font
'help-echo
(concat (car m)
(format " at %s." (cdr m) )
"\nright click to jump there." )
'position (cdr m)
'type 'right
'nonterminal (car m)
'keymap map-right-nonterminal) )
(push (match-beginning 1) match-positions) ) )
;; add text properties to the left nonterminal
(add-text-properties
(cdr m) (+ (length (car m) ) (cdr m) )
(list
'help-echo (concat "`" (car m) "'" " "
(if match-positions
(format "at %s" (reverse match-positions) )
"is a start symbol" )
(format
".\n %s to rotate around matches."
(substitute-command-keys "\\[bn-search]") ) )
'position (progn
(let ( ( ring-positions (make-ring (length match-positions) ) ) )
(dolist (p (reverse match-positions) )
(ring-insert ring-positions p) )
ring-positions) )
'nonterminal (car m)
'type 'left
'keymap map-left-nonterminal) )
(push (cons m match-positions) bn-left-nonterminal-list ) ) )
;; restore the undo, modified status
(restore-buffer-modified-p buffer-modified-flag)
(buffer-enable-undo)
(setq buffer-undo-list ul ) ) ) )
(defun bn-change (x y z)
"hook which is called after every buffer change. it starts a
timer that fontify the current buffer, according to the rules
defined in the grammar. if a previous timer is active, stop it
before starting the new timer."
;; clear the overlays from the previous search if any
(bn-stop-timer)
'(setq overriding-terminal-local-map nil)
(setq bn-timer-var
(run-with-idle-timer
1 nil 'bn-timer-font-lock-right-nonterminals) ) )
(defun bn-beginning-of-defun ()
"jump at the beginning of a left nonterminal definition."
(search-backward-regexp bn-left-nonterminal-definition nil t) )
(defun bn-end-of-defun ()
"jump at the end of a left nonterminal definition."
(if (search-forward-regexp bn-left-nonterminal-definition nil t)
(beginning-of-line)
(bn-jump (point-max) ) )
(let ((repeat t))
(while repeat
(skip-chars-backward " \t\n")
(if (not (bn-commented-line-p) )
(setq repeat nil)
(beginning-of-line) ) ) )
(skip-chars-forward " \t")
(and (not (eobp) )
(forward-char) ) )
(defun bn-search ()
"Search for the left nonterminal under the cursor"
(interactive)
(let* ((left-nonterminal (get-text-property (point) 'nonterminal ) )
(left-nonterminal-positions
(and left-nonterminal
(get-text-property (point) 'position ) ) ) )
(cond
;; a symbol accessed from nowhere
( (and
(ring-p left-nonterminal-positions )
(ring-empty-p left-nonterminal-positions ) )
(message "`%s' is a start symbol" left-nonterminal ) )
;; at cursor position there is a left nonterminal
( (ring-p left-nonterminal-positions )
;; fontify right nonterminals that match
(dolist (p (ring-elements left-nonterminal-positions ) )
(let ((ov (make-overlay p (+ p (length left-nonterminal ) ) ) ) )
(overlay-put ov 'face 'bn-search-rotate-face) ) )
;; loop of input events
(let* (key
(l t)
(pos 0)
(number-of-matches (ring-size left-nonterminal-positions ) )
(many-matches (> number-of-matches 1 ) )
(Mkeys (concat
"\n"
(if many-matches
"`n' jump to the next match. `p' jump to the previous match. "
"" )
"`q' interrupts search." ) )
(M (concat
(format "`%s'" left-nonterminal )
(format " : `%s': " (reverse (ring-elements left-nonterminal-positions ) ) )
Mkeys ) ) )
;; jump to the first match
(bn-jump (ring-ref left-nonterminal-positions pos) )
(recenter)
(message (concat "Search for " M ) )
(while l
(setq key (read-key-sequence nil) )
(cond
;; quit the search
( (and (stringp key)
(string-equal key "q" ) )
(message "quit search." )
(setq l nil ) )
;; searck for the next match
( (and (stringp key)
many-matches
(string-equal key "n" ) )
(setq pos (1- pos) )
(goto-char (ring-ref left-nonterminal-positions pos) )
(message M ) )
;; search for the previous match
( (and (stringp key)
many-matches
(string-equal key "p" ) )
(setq pos (1+ pos) )
(goto-char (ring-ref left-nonterminal-positions pos ) )
(message M ) )
(t
(message
(concat (format "`%s'" (key-description key ) )
" does not match. "
Mkeys ) ) ) ) ) )
;; removing overlays
(remove-overlays) )
((listp left-nonterminal-positions )
(error "No left-nonterminal defintion at point" ))
(t
(error " `%s' : cannot loop for a right symbol. " left-nonterminal ) ) ) ) )
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2009-11-04 14:39 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2009-11-04 14:39 Backus-Naur major mode Alin Soare
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).