elisp/geiser-syntax.el

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