geiser-syntax.el (20543B)
1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2016, 2019-2022 Jose Antonio Ortega Ruiz 4 5 ;; This program is free software; you can redistribute it and/or 6 ;; modify it under the terms of the Modified BSD License. You should 7 ;; have received a copy of the license along with this program. If 8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>. 9 10 ;; Start date: Sun Feb 08, 2009 15:03 11 12 13 ;;; Code: 14 15 (require 'geiser-impl) 16 (require 'geiser-popup) 17 (require 'geiser-base) 18 19 (require 'scheme) 20 21 (eval-when-compile 22 (require 'cl-lib) 23 (require 'subr-x)) 24 25 26 ;;; Indentation: 27 28 (defmacro geiser-syntax--scheme-indent (&rest pairs) 29 `(progn ,@(mapcar (lambda (p) 30 `(put ',(car p) 'scheme-indent-function ',(cadr p))) 31 pairs))) 32 33 (geiser-syntax--scheme-indent 34 (and-let* 1) 35 (case-lambda 0) 36 (catch defun) 37 (class defun) 38 (dynamic-wind 0) 39 (guard 1) 40 (let*-values 1) 41 (let-values 1) 42 (let/ec 1) 43 (letrec* 1) 44 (match 1) 45 (match-lambda 0) 46 (match-lambda* 0) 47 (match-let scheme-let-indent) 48 (match-let* 1) 49 (match-letrec 1) 50 (opt-lambda 1) 51 (parameterize 1) 52 (parameterize* 1) 53 (receive 2) 54 (require-extension 0) 55 (syntax-case 2) 56 (test-approximate 1) 57 (test-assert 1) 58 (test-eq 1) 59 (test-equal 1) 60 (test-eqv 1) 61 (test-group 1) 62 (test-group-with-cleanup 1) 63 (test-runner-on-bad-count! 1) 64 (test-runner-on-bad-end-name! 1) 65 (test-runner-on-final! 1) 66 (test-runner-on-group-begin! 1) 67 (test-runner-on-group-end! 1) 68 (test-runner-on-test-begin! 1) 69 (test-runner-on-test-end! 1) 70 (test-with-runner 1) 71 (unless 1) 72 (when 1) 73 (while 1) 74 (with-exception-handler 1) 75 (with-syntax 1)) 76 77 78 ;;; Extra syntax keywords 79 80 (defconst geiser-syntax--builtin-keywords 81 '("and-let*" 82 "cut" 83 "cute" 84 "define-condition-type" 85 "define-immutable-record-type" 86 "define-record-type" 87 "define-values" 88 "letrec*" 89 "match" 90 "match-lambda" 91 "match-lambda*" 92 "match-let" 93 "match-let*" 94 "match-letrec" 95 "parameterize" 96 "receive" 97 "require-extension" 98 "set!" 99 "syntax-case" 100 "test-approximate" 101 "test-assert" 102 "test-begin" 103 "test-end" 104 "test-eq" 105 "test-equal" 106 "test-eqv" 107 "test-error" 108 "test-group" 109 "test-group-with-cleanup" 110 "test-with-runner" 111 "unless" 112 "when" 113 "with-exception-handler" 114 "with-input-from-file" 115 "with-output-to-file")) 116 117 (defun geiser-syntax--simple-keywords (keywords) 118 "Return `font-lock-keywords' to highlight scheme KEYWORDS. 119 KEYWORDS should be a list of strings." 120 (when keywords 121 `((,(format "[[(]%s\\>" (regexp-opt keywords 1)) . 1)))) 122 123 (defun geiser-syntax--keywords () 124 (append 125 (geiser-syntax--simple-keywords geiser-syntax--builtin-keywords) 126 `(("\\[\\(else\\)\\>" . 1) 127 (,(rx "(" (group "define-syntax-rule") eow (* space) 128 (? "(") (? (group (1+ word)))) 129 (1 font-lock-keyword-face) 130 (2 font-lock-function-name-face nil t))))) 131 132 (font-lock-add-keywords 'scheme-mode (geiser-syntax--keywords)) 133 134 (geiser-impl--define-caller geiser-syntax--impl-kws keywords () 135 "A variable (or thunk returning a value) giving additional, 136 implementation-specific entries for font-lock-keywords.") 137 138 (geiser-impl--define-caller geiser-syntax--case-sensitive case-sensitive () 139 "A flag saying whether keywords are case sensitive.") 140 141 (defun geiser-syntax--add-kws (&optional global-p) 142 (unless (bound-and-true-p quack-mode) 143 (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation)) 144 (cs (geiser-syntax--case-sensitive geiser-impl--implementation))) 145 (when kw (font-lock-add-keywords nil kw)) 146 (when global-p (font-lock-add-keywords nil (geiser-syntax--keywords))) 147 (setq font-lock-keywords-case-fold-search (not cs))))) 148 149 (defun geiser-syntax--remove-kws () 150 (unless (bound-and-true-p quack-mode) 151 (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation))) 152 (when kw 153 (font-lock-remove-keywords nil kw))))) 154 155 156 ;;; A simple scheme reader 157 158 (defvar geiser-syntax--read/buffer-limit nil) 159 160 (defsubst geiser-syntax--read/eos () 161 (or (eobp) 162 (and geiser-syntax--read/buffer-limit 163 (<= geiser-syntax--read/buffer-limit (point))))) 164 165 (defsubst geiser-syntax--read/next-char () 166 (unless (geiser-syntax--read/eos) 167 (forward-char) 168 (char-after))) 169 170 (defsubst geiser-syntax--read/token (token) 171 (geiser-syntax--read/next-char) 172 (if (listp token) token (list token))) 173 174 (defsubst geiser-syntax--read/elisp () 175 (ignore-errors (read (current-buffer)))) 176 177 (defun geiser-syntax--read/symbol () 178 (with-syntax-table scheme-mode-syntax-table 179 (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t) 180 (make-symbol (match-string-no-properties 0))))) 181 182 (defun geiser-syntax--read/matching (open close) 183 (let ((count 1) 184 (p (1+ (point)))) 185 (while (and (> count 0) 186 (geiser-syntax--read/next-char)) 187 (cond ((looking-at-p open) (setq count (1+ count))) 188 ((looking-at-p close) (setq count (1- count))))) 189 (buffer-substring-no-properties p (point)))) 190 191 (defsubst geiser-syntax--read/unprintable () 192 (geiser-syntax--read/token 193 (cons 'unprintable (geiser-syntax--read/matching "<" ">")))) 194 195 (defun geiser-syntax--read/ex-symbol () ;; #{foo bar}# style symbols 196 (let ((tk (geiser-syntax--read/matching "{" "}"))) 197 (when-let (c (geiser-syntax--read/next-char)) 198 (when (char-equal ?\# c) 199 (geiser-syntax--read/next-char) 200 (cons 'atom (make-symbol (format "#{%s}#" tk))))))) 201 202 (defun geiser-syntax--read/skip-comment () 203 (while (and (geiser-syntax--read/next-char) 204 (nth 8 (syntax-ppss)))) 205 (geiser-syntax--read/next-token)) 206 207 (defun geiser-syntax--read/next-token () 208 (skip-syntax-forward "->") 209 (if (geiser-syntax--read/eos) '(eob) 210 (cl-case (char-after) 211 (?\; (geiser-syntax--read/skip-comment)) 212 ((?\( ?\[) (geiser-syntax--read/token 'lparen)) 213 ((?\) ?\]) (geiser-syntax--read/token 'rparen)) 214 (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12)) 215 (geiser-syntax--read/token 'dot) 216 (cons 'atom (geiser-syntax--read/elisp)))) 217 (?\# (cl-case (geiser-syntax--read/next-char) 218 ((nil quote) '(eob)) 219 (?| (geiser-syntax--read/skip-comment)) 220 (?: (if (geiser-syntax--read/next-char) 221 (cons 'kwd (geiser-syntax--read/symbol)) 222 '(eob))) 223 (?\\ (cons 'char (geiser-syntax--read/elisp))) 224 (?\( (geiser-syntax--read/token 'vectorb)) 225 (?\< (geiser-syntax--read/unprintable)) 226 ((?' ?` ?,) (geiser-syntax--read/next-token)) 227 (?\{ (geiser-syntax--read/ex-symbol)) 228 (t (let ((tok (geiser-syntax--read/symbol))) 229 (cond ((equal (symbol-name tok) "t") '(boolean . :t)) 230 ((equal (symbol-name tok) "f") '(boolean . :f)) 231 (tok (cons 'atom tok)) 232 (t (geiser-syntax--read/next-token))))))) 233 (?| (cl-case (geiser-syntax--read/next-char) ;; gambit style block comments 234 ((nil quote) '(eob)) 235 (?# (geiser-syntax--read/skip-comment)) 236 (t (let ((tok (geiser-syntax--read/symbol))) 237 (cond ((equal (symbol-name tok) "t") '(boolean . :t)) 238 ((equal (symbol-name tok) "f") '(boolean . :f)) 239 (tok (cons 'atom tok)) 240 (t (geiser-syntax--read/next-token))))))) 241 (?\' (geiser-syntax--read/token '(quote . quote))) 242 (?\` (geiser-syntax--read/token 243 `(backquote . ,backquote-backquote-symbol))) 244 (?, (if (eq (geiser-syntax--read/next-char) ?@) 245 (geiser-syntax--read/token 246 `(splice . ,backquote-splice-symbol)) 247 `(unquote . ,backquote-unquote-symbol))) 248 (?\" (cons 'string (geiser-syntax--read/elisp))) 249 (t (let ((x (geiser-syntax--read/elisp))) 250 (cons 'atom (if (atom x) x (geiser-syntax--read/symbol)))))))) 251 252 (defsubst geiser-syntax--read/match (&rest tks) 253 (let ((token (geiser-syntax--read/next-token))) 254 (if (memq (car token) tks) token 255 (error "Unexpected token: %s" token)))) 256 257 (defsubst geiser-syntax--read/skip-until (&rest tks) 258 (let (token) 259 (while (and (not (memq (car token) tks)) 260 (not (eq (car token) 'eob))) 261 (setq token (geiser-syntax--read/next-token))) 262 token)) 263 264 (defsubst geiser-syntax--read/try (&rest tks) 265 (let ((p (point)) 266 (tk (ignore-errors (apply 'geiser-syntax--read/match tks)))) 267 (unless tk (goto-char p)) 268 tk)) 269 270 (defun geiser-syntax--read/list () 271 (cond ((geiser-syntax--read/try 'dot) 272 (let ((tail (geiser-syntax--read))) 273 (geiser-syntax--read/skip-until 'eob 'rparen) 274 tail)) 275 ((geiser-syntax--read/try 'rparen 'eob) nil) 276 (t (cons (geiser-syntax--read) 277 (geiser-syntax--read/list))))) 278 279 (defun geiser-syntax--read () 280 (let ((token (geiser-syntax--read/next-token)) 281 (max-lisp-eval-depth (max max-lisp-eval-depth 3000))) 282 (cl-case (car token) 283 (eob nil) 284 (lparen (geiser-syntax--read/list)) 285 (vectorb (apply 'vector (geiser-syntax--read/list))) 286 ((quote backquote unquote splice) (list (cdr token) 287 (geiser-syntax--read))) 288 (kwd (make-symbol (format ":%s" (cdr token)))) 289 (unprintable (format "#<%s>" (cdr token))) 290 ((char string atom) (cdr token)) 291 (boolean (cdr token)) 292 (t (error "Reading scheme syntax: unexpected token: %s" token))))) 293 294 (defun geiser-syntax--read-from-string (string &optional start end) 295 (when (stringp string) 296 ;; In Emacs 29 this variable doesn't have an effect 297 ;; anymore and `max-lisp-eval-depth' achieves the same. 298 (with-suppressed-warnings ((obsolete max-specpdl-size)) 299 (let* ((start (or start 0)) 300 (end (or end (length string))) 301 (max-lisp-eval-depth (min 20000 302 (max max-lisp-eval-depth (- end start)))) 303 (max-specpdl-size (* 2 max-lisp-eval-depth))) 304 (with-temp-buffer 305 (save-excursion (insert string)) 306 (cons (geiser-syntax--read) (point))))))) 307 308 (defun geiser-syntax--form-from-string (s) 309 (car (geiser-syntax--read-from-string s))) 310 311 (defsubst geiser-syntax--form-after-point (&optional boundary) 312 (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary))) 313 (save-excursion (list (geiser-syntax--read) (point))))) 314 315 (defun geiser-syntax--mapconcat (fun lst sep) 316 (cond ((null lst) "") 317 ((not (listp lst)) (format ".%s%s" sep (funcall fun lst))) 318 ((null (cdr lst)) (format "%s" (funcall fun (car lst)))) 319 (t (format "%s%s%s" 320 (funcall fun (car lst)) 321 sep 322 (geiser-syntax--mapconcat fun (cdr lst) sep))))) 323 324 325 ;;; Code parsing: 326 327 (defsubst geiser-syntax--symbol-at-point () 328 (and (not (nth 8 (syntax-ppss))) 329 (car (geiser-syntax--read-from-string (thing-at-point 'symbol))))) 330 331 (defsubst geiser-syntax--skip-comment/string () 332 (let ((pos (nth 8 (syntax-ppss)))) 333 (goto-char (or pos (point))) 334 pos)) 335 336 (defsubst geiser-syntax--nesting-level () 337 (or (nth 0 (syntax-ppss)) 0)) 338 339 (defun geiser-syntax--pop-to-top () 340 (ignore-errors 341 (while (> (geiser-syntax--nesting-level) 0) (backward-up-list)))) 342 343 (defsubst geiser-syntax--in-string-p () 344 (nth 3 (syntax-ppss))) 345 346 (defsubst geiser-syntax--pair-length (p) 347 (if (cdr (last p)) (1+ (safe-length p)) (length p))) 348 349 (defun geiser-syntax--shallow-form (boundary) 350 (when (looking-at-p "\\s(") 351 (save-excursion 352 (forward-char) 353 (let ((elems)) 354 (ignore-errors 355 (while (< (point) boundary) 356 (skip-syntax-forward "-<>") 357 (when (<= (point) boundary) 358 (forward-sexp) 359 (let ((s (thing-at-point 'symbol))) 360 (unless (equal "." s) 361 (push (car (geiser-syntax--read-from-string s)) elems)))))) 362 (nreverse elems))))) 363 364 (defsubst geiser-syntax--keywordp (s) 365 (and s (symbolp s) (string-match "^:.+" (symbol-name s)))) 366 367 (defsubst geiser-syntax--symbol-eq (s0 s1) 368 (and (symbolp s0) (symbolp s1) (equal (symbol-name s0) (symbol-name s1)))) 369 370 (defun geiser-syntax--scan-sexps () 371 (let* ((fst (geiser-syntax--symbol-at-point)) 372 (smth (or fst (not (looking-at-p "[\s \s)\s>\s<\n]")))) 373 (path (and fst `((,fst 0))))) 374 (save-excursion 375 (while (> (or (geiser-syntax--nesting-level) 0) 0) 376 (let ((boundary (point))) 377 (geiser-syntax--skip-comment/string) 378 (backward-up-list) 379 (let ((form (geiser-syntax--shallow-form boundary))) 380 (when (and (listp form) (car form) (symbolp (car form))) 381 (let* ((len (geiser-syntax--pair-length form)) 382 (pos (if smth (1- len) (progn (setq smth t) len))) 383 (prev (and (> pos 1) (nth (1- pos) form))) 384 (prev (and (geiser-syntax--keywordp prev) 385 (list prev)))) 386 (push `(,(car form) ,pos ,@prev) path))))))) 387 (mapcar (lambda (e) 388 (cons (substring-no-properties (format "%s" (car e))) (cdr e))) 389 (nreverse path)))) 390 391 (defsubst geiser-syntax--binding-form-p (bfs sbfs f) 392 (and (symbolp f) 393 (let ((f (symbol-name f))) 394 (or (member f '("define" "define*" "define-syntax" 395 "syntax-rules" "lambda" "case-lambda" 396 "let" "let*" "let-values" "let*-values" 397 "letrec" "letrec*" "parameterize")) 398 (member f bfs) 399 (member f sbfs))))) 400 401 (defsubst geiser-syntax--binding-form*-p (sbfs f) 402 (and (symbolp f) 403 (let ((f (symbol-name f))) 404 (or (member f '("let*" "let*-values" "letrec" "letrec*")) 405 (member f sbfs))))) 406 407 (defsubst geiser-syntax--if-symbol (x) (and (symbolp x) x)) 408 (defsubst geiser-syntax--if-list (x) (and (listp x) x)) 409 410 (defsubst geiser-syntax--normalize (vars) 411 (mapcar (lambda (i) 412 (let ((i (if (listp i) (car i) i))) 413 (and (symbolp i) (symbol-name i)))) 414 vars)) 415 416 (defun geiser-syntax--linearize (form) 417 (cond ((not (listp form)) (list form)) 418 ((null form) nil) 419 (t (cons (car form) (geiser-syntax--linearize (cdr form)))))) 420 421 (defun geiser-syntax--scan-locals (bfs sbfs form nesting locals) 422 (if (or (null form) (not (listp form))) 423 (geiser-syntax--normalize locals) 424 (if (not (geiser-syntax--binding-form-p bfs sbfs (car form))) 425 (geiser-syntax--scan-locals bfs sbfs 426 (car (last form)) 427 (1- nesting) locals) 428 (let* ((head (car form)) 429 (name (geiser-syntax--if-symbol (cadr form))) 430 (names (if name (geiser-syntax--if-list (caddr form)) 431 (geiser-syntax--if-list (cadr form)))) 432 (bns (and name 433 (geiser-syntax--binding-form-p bfs sbfs (car names)))) 434 (rest (if (and name (not bns)) (cdddr form) (cddr form))) 435 (use-names (and (or rest 436 (< nesting 1) 437 (geiser-syntax--binding-form*-p sbfs head)) 438 (not bns)))) 439 (when name (push name locals)) 440 (when (geiser-syntax--symbol-eq head 'case-lambda) 441 (dolist (n (and (> nesting 0) (caar (last form)))) 442 (when n (push n locals))) 443 (setq rest (and (> nesting 0) (cdr form))) 444 (setq use-names nil)) 445 (when (geiser-syntax--symbol-eq head 'syntax-rules) 446 (dolist (n (and (> nesting 0) (cdaar (last form)))) 447 (when n (push n locals))) 448 (setq rest (and (> nesting 0) (cdr form)))) 449 (when use-names 450 (dolist (n (geiser-syntax--linearize names)) 451 (let ((xs (if (and (listp n) (listp (car n))) (car n) (list n)))) 452 (dolist (x xs) (when x (push x locals)))))) 453 (dolist (f (butlast rest)) 454 (when (and (listp f) 455 (geiser-syntax--symbol-eq (car f) 'define) 456 (cadr f)) 457 (push (cadr f) locals))) 458 (geiser-syntax--scan-locals bfs sbfs 459 (car (last (or rest names))) 460 (1- nesting) 461 locals))))) 462 463 (defun geiser-syntax--locals-around-point (bfs sbfs) 464 (when (eq major-mode 'scheme-mode) 465 (save-excursion 466 (let ((sym (unless (geiser-syntax--skip-comment/string) 467 (thing-at-point 'symbol)))) 468 (skip-syntax-forward "->") 469 (let ((boundary (point)) 470 (nesting (geiser-syntax--nesting-level))) 471 (geiser-syntax--pop-to-top) 472 (cl-destructuring-bind (form _end) 473 (geiser-syntax--form-after-point boundary) 474 (delete sym 475 (geiser-syntax--scan-locals bfs 476 sbfs 477 form 478 (1- nesting) 479 '())))))))) 480 481 482 ;;; Display and fontify strings as Scheme code: 483 484 (defun geiser-syntax--display (a) 485 (cond ((null a) "()") 486 ((eq a :t) "#t") 487 ((eq a :f) "#f") 488 ((geiser-syntax--keywordp a) (format "#%s" a)) 489 ((symbolp a) (format "%s" a)) 490 ((equal a "...") "...") 491 ((stringp a) (format "%S" a)) 492 ((and (listp a) (symbolp (car a)) 493 (equal (symbol-name (car a)) "quote")) 494 (format "'%s" (geiser-syntax--display (cadr a)))) 495 ((listp a) 496 (format "(%s)" 497 (geiser-syntax--mapconcat 'geiser-syntax--display a " "))) 498 (t (format "%s" a)))) 499 500 (defconst geiser-syntax--font-lock-buffer-name " *Geiser font-lock*") 501 502 (defun geiser-syntax--font-lock-buffer-p (&optional buffer) 503 (equal (buffer-name buffer) geiser-syntax--font-lock-buffer-name)) 504 505 (defun geiser-syntax--font-lock-buffer () 506 (or (get-buffer geiser-syntax--font-lock-buffer-name) 507 (let ((buffer (get-buffer-create geiser-syntax--font-lock-buffer-name))) 508 (set-buffer buffer) 509 (let ((geiser-default-implementation 510 (or geiser-default-implementation 511 (car geiser-active-implementations)))) 512 (scheme-mode)) 513 buffer))) 514 515 (defun geiser-syntax--fontify (&optional beg end) 516 (let ((font-lock-verbose nil) 517 (beg (or beg (point-min))) 518 (end (or end (point-max)))) 519 (if (fboundp 'font-lock-flush) 520 (font-lock-flush beg end) 521 (with-no-warnings (font-lock-fontify-region beg end))))) 522 523 ;; derived from org-src-font-lock-fontify-block (org-src.el) 524 (defun geiser-syntax--fontify-syntax-region (start end) 525 "Fontify region as Scheme." 526 (let ((string (buffer-substring-no-properties start end)) 527 (modified (buffer-modified-p)) 528 (buffer-undo-list t) 529 (geiser-buffer (current-buffer))) 530 (with-current-buffer 531 (get-buffer-create " *Geiser REPL fontification*") 532 (let ((inhibit-modification-hooks nil)) 533 (erase-buffer) 534 ;; Add string and a final space to ensure property change. 535 (insert string " ")) 536 ;; prevent geiser prompt 537 (let ((geiser-default-implementation 538 (or geiser-default-implementation 539 (car geiser-active-implementations)))) 540 (scheme-mode)) 541 (geiser--font-lock-ensure) 542 (let ((pos (point-min)) next) 543 (while (setq next (next-property-change pos)) 544 ;; Handle additional properties from font-lock, so as to 545 ;; preserve, e.g., composition. 546 (dolist (prop (cons 'face font-lock-extra-managed-props)) 547 (let ((new-prop (get-text-property pos prop)) 548 (start-point (+ start (1- pos))) 549 (end-point (1- (+ start next)))) 550 (put-text-property start-point end-point prop new-prop geiser-buffer))) 551 (setq pos next)))) 552 (add-text-properties 553 start end 554 '(font-lock-fontified t 555 fontified t 556 font-lock-multiline t)) 557 (set-buffer-modified-p modified))) 558 559 (defun geiser-syntax--scheme-str (str) 560 (save-current-buffer 561 (set-buffer (geiser-syntax--font-lock-buffer)) 562 (erase-buffer) 563 (insert str) 564 (geiser-syntax--fontify) 565 (buffer-string))) 566 567 568 (provide 'geiser-syntax)