elisp/geiser-syntax.el

   1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
   2
   3 ;; Copyright (C) 2009, 2010 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
  14 (require 'geiser-impl)
  15 (require 'geiser-popup)
  16 (require 'geiser-base)
  17
  18 (require 'scheme)
  19
  20 (eval-when-compile (require 'cl))
  21
  22 \f
  23 ;;; Indentation:
  24
  25 (defmacro geiser-syntax--scheme-indent (&rest pairs)
  26   `(progn ,@(mapcar (lambda (p)
  27                       `(put ',(car p) 'scheme-indent-function ',(cadr p)))
  28                     pairs)))
  29
  30 (geiser-syntax--scheme-indent
  31  (begin0 1)
  32  (c-declare 0)
  33  (c-lambda 2)
  34  (case-lambda 0)
  35  (case-lambda: 0)
  36  (catch defun)
  37  (class defun)
  38  (class* defun)
  39  (compound-unit/sig 0)
  40  (define: defun)
  41  (dynamic-wind 0)
  42  (for/fold 2)
  43  (instantiate 2)
  44  (interface 1)
  45  (lambda: 1)
  46  (lambda/kw 1)
  47  (let*-values 1)
  48  (let*-values: 1)
  49  (let+ 1)
  50  (let: 1)
  51  (letrec: 1)
  52  (letrec* 1)
  53  (letrec-values 1)
  54  (letrec-values: 1)
  55  (let-values 1)
  56  (let-values: 1)
  57  (let/cc: 1)
  58  (let/ec 1)
  59  (match defun)
  60  (mixin 2)
  61  (module defun)
  62  (opt-lambda 1)
  63  (parameterize 1)
  64  (parameterize-break 1)
  65  (parameterize* 1)
  66  (pmatch defun)
  67  (quasisyntax/loc 1)
  68  (receive 2)
  69  (send* 1)
  70  (sigaction 1)
  71  (syntax-case 2)
  72  (syntax/loc 1)
  73  (type-case defun)
  74  (unit defun)
  75  (unit/sig 2)
  76  (unless 1)
  77  (when 1)
  78  (while 1)
  79  (with-fluid* 1)
  80  (with-fluids 1)
  81  (with-fluids* 1)
  82  (with-handlers 1)
  83  (with-handlers: 1)
  84  (with-method 1)
  85  (with-syntax 1))
  86
  87 \f
  88 ;;; Extra syntax keywords
  89 (defconst geiser-syntax--keywords
  90   '(("\\[\\(else\\)\\>" . 1)
  91     ("(\\(parameterize\\)\\>" . 1)))
  92
  93 (font-lock-add-keywords 'scheme-mode geiser-syntax--keywords)
  94
  95 (geiser-impl--define-caller geiser-syntax--impl-kws keywords ()
  96   "A variable (or thunk returning a value) giving additional,
  97 implementation-specific entries for font-lock-keywords.")
  98
  99 (defun geiser-syntax--add-kws ()
 100   (when (not (and (boundp 'quack-mode) quack-mode))
 101     (let ((kw (geiser-syntax--impl-kws geiser-impl--implementation)))
 102       (when kw (font-lock-add-keywords nil kw)))))
 103
 104 \f
 105 ;;; A simple scheme reader
 106
 107 (defvar geiser-syntax--read/buffer-limit nil)
 108
 109 (defsubst geiser-syntax--read/eos ()
 110   (or (eobp)
 111       (and geiser-syntax--read/buffer-limit
 112            (<= geiser-syntax--read/buffer-limit (point)))))
 113
 114 (defsubst geiser-syntax--read/next-char ()
 115   (unless (geiser-syntax--read/eos)
 116     (forward-char)
 117     (char-after)))
 118
 119 (defsubst geiser-syntax--read/token (token)
 120   (geiser-syntax--read/next-char)
 121   (if (listp token) token (list token)))
 122
 123 (defsubst geiser-syntax--read/elisp ()
 124   (ignore-errors (read (current-buffer))))
 125
 126 (defun geiser-syntax--read/symbol ()
 127   (with-syntax-table scheme-mode-syntax-table
 128     (when (re-search-forward "\\(\\sw\\|\\s_\\)+" nil t)
 129       (make-symbol (match-string-no-properties 0)))))
 130
 131 (defun geiser-syntax--read/matching (open close)
 132   (let ((count 1)
 133         (p (1+ (point))))
 134     (while (and (> count 0)
 135                 (geiser-syntax--read/next-char))
 136       (cond ((looking-at-p open) (setq count (1+ count)))
 137             ((looking-at-p close) (setq count (1- count)))))
 138     (buffer-substring-no-properties p (point))))
 139
 140 (defsubst geiser-syntax--read/unprintable ()
 141   (geiser-syntax--read/token
 142    (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
 143
 144 (defun geiser-syntax--read/skip-comment ()
 145   (while (and (geiser-syntax--read/next-char)
 146               (nth 8 (syntax-ppss))))
 147   (geiser-syntax--read/next-token))
 148
 149 (defun geiser-syntax--read/next-token ()
 150   (skip-syntax-forward "->")
 151   (if (geiser-syntax--read/eos) '(eob)
 152     (case (char-after)
 153       (?\; (geiser-syntax--read/skip-comment))
 154       ((?\( ?\[) (geiser-syntax--read/token 'lparen))
 155       ((?\) ?\]) (geiser-syntax--read/token 'rparen))
 156       (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
 157               (geiser-syntax--read/token 'dot)
 158             (cons 'atom (geiser-syntax--read/elisp))))
 159       (?\# (case (geiser-syntax--read/next-char)
 160              ('nil '(eob))
 161              (?| (geiser-syntax--read/skip-comment))
 162              (?: (if (geiser-syntax--read/next-char)
 163                      (cons 'kwd (geiser-syntax--read/symbol))
 164                    '(eob)))
 165              (?\\ (cons 'char (geiser-syntax--read/elisp)))
 166              (?\( (geiser-syntax--read/token 'vectorb))
 167              (?\< (geiser-syntax--read/unprintable))
 168              ((?' ?` ?,) (geiser-syntax--read/next-token))
 169              (t (let ((tok (geiser-syntax--read/symbol)))
 170                   (cond ((equal (symbol-name tok) "t") '(boolean . :t))
 171                         ((equal (symbol-name tok) "f") '(boolean . :f))
 172                         (tok (cons 'atom (make-symbol (format "#%s" tok))))
 173                         (t (geiser-syntax--read/next-token)))))))
 174       (?\' (geiser-syntax--read/token '(quote . quote)))
 175       (?\` (geiser-syntax--read/token
 176             `(backquote . ,backquote-backquote-symbol)))
 177       (?, (if (eq (geiser-syntax--read/next-char) ?@)
 178               (geiser-syntax--read/token
 179                `(splice . ,backquote-splice-symbol))
 180             `(unquote . ,backquote-unquote-symbol)))
 181       (?\" (cons 'string (geiser-syntax--read/elisp)))
 182       (t (cons 'atom (geiser-syntax--read/symbol))))))
 183
 184 (defsubst geiser-syntax--read/match (&rest tks)
 185   (let ((token (geiser-syntax--read/next-token)))
 186     (if (memq (car token) tks) token
 187       (error "Unexpected token: %s" token))))
 188
 189 (defsubst geiser-syntax--read/skip-until (&rest tks)
 190   (let (token)
 191     (while (and (not (memq (car token) tks))
 192                 (not (eq (car token) 'eob)))
 193       (setq token (geiser-syntax--read/next-token)))
 194     token))
 195
 196 (defsubst geiser-syntax--read/try (&rest tks)
 197   (let ((p (point))
 198         (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
 199     (unless tk (goto-char p))
 200     tk))
 201
 202 (defun geiser-syntax--read/list ()
 203   (cond ((geiser-syntax--read/try 'dot)
 204          (let ((tail (geiser-syntax--read)))
 205            (geiser-syntax--read/skip-until 'eob 'rparen)
 206            tail))
 207         ((geiser-syntax--read/try 'rparen 'eob) nil)
 208         (t (cons (geiser-syntax--read)
 209                  (geiser-syntax--read/list)))))
 210
 211 (defun geiser-syntax--read ()
 212   (let ((token (geiser-syntax--read/next-token))
 213         (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
 214     (case (car token)
 215       (eob nil)
 216       (lparen (geiser-syntax--read/list))
 217       (vectorb (apply 'vector (geiser-syntax--read/list)))
 218       ((quote backquote unquote splice) (list (cdr token)
 219                                               (geiser-syntax--read)))
 220       (kwd (make-symbol (format ":%s" (cdr token))))
 221       (unprintable (format "#<%s>" (cdr token)))
 222       ((char string atom) (cdr token))
 223       (boolean (cdr token))
 224       (t (error "Reading scheme syntax: unexpected token: %s" token)))))
 225
 226 (defun geiser-syntax--read-from-string (string &optional start end)
 227   (when (stringp string)
 228     (let* ((start (or start 0))
 229            (end (or end (length string)))
 230            (max-lisp-eval-depth (max max-lisp-eval-depth (- end start))))
 231       (with-temp-buffer
 232         (save-excursion (insert string))
 233         (cons (ignore-errors (geiser-syntax--read)) (point))))))
 234
 235 (defsubst geiser-syntax--form-after-point (&optional boundary)
 236   (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
 237     (save-excursion (values (geiser-syntax--read) (point)))))
 238
 239 (defun geiser-syntax--mapconcat (fun lst sep)
 240   (cond ((null lst) "")
 241         ((not (listp lst)) (format ".%s%s" sep (funcall fun lst)))
 242         ((null (cdr lst)) (format "%s" (funcall fun (car lst))))
 243         (t (format "%s%s%s"
 244                    (funcall fun (car lst))
 245                    sep
 246                    (geiser-syntax--mapconcat fun (cdr lst) sep)))))
 247
 248 (defun geiser-syntax--display (a)
 249   (cond ((null a) "()")
 250         ((eq a :t) "#t")
 251         ((eq a :f) "#f")
 252         ((geiser-syntax--keywordp a) (format "#%s" a))
 253         ((symbolp a) (format "%s" a))
 254         ((equal a "...") "...")
 255         ((stringp a) (format "%S" a))
 256         ((and (listp a) (symbolp (car a))
 257               (equal (symbol-name (car a)) "quote"))
 258          (format "'%s" (geiser-syntax--display (cadr a))))
 259         ((listp a)
 260          (format "(%s)"
 261                  (geiser-syntax--mapconcat 'geiser-syntax--display a " ")))
 262         (t (format "%s" a))))
 263
 264 \f
 265 ;;; Code parsing:
 266
 267 (defsubst geiser-syntax--symbol-at-point ()
 268   (and (not (nth 8 (syntax-ppss)))
 269        (let ((s (thing-at-point 'symbol)))
 270          (and s
 271               (not (equal s "."))
 272               (make-symbol (substring-no-properties s))))))
 273
 274 (defsubst geiser-syntax--skip-comment/string ()
 275   (let ((pos (nth 8 (syntax-ppss))))
 276     (goto-char (or pos (point)))
 277     pos))
 278
 279 (defsubst geiser-syntax--nesting-level ()
 280   (or (nth 0 (syntax-ppss)) 0))
 281
 282 (defsubst geiser-syntax--pair-length (p)
 283   (if (cdr (last p)) (1+ (safe-length p)) (length p)))
 284
 285 (defun geiser-syntax--shallow-form (boundary)
 286   (when (looking-at-p "\\s(")
 287     (save-excursion
 288       (forward-char)
 289       (let ((elems))
 290         (ignore-errors
 291           (while (< (point) boundary)
 292             (skip-syntax-forward "-<>")
 293             (when (<= (point) boundary)
 294               (forward-sexp)
 295               (let ((s (thing-at-point 'symbol)))
 296                 (cond ((not s) (push s elems))
 297                       ((not (equal "." s)) (push (make-symbol s) elems)))))))
 298         (nreverse elems)))))
 299
 300 (defsubst geiser-syntax--keywordp (s)
 301   (and s (symbolp s) (string-match "^:.+" (symbol-name s))))
 302
 303 (defsubst geiser-syntax--symbol-eq (s0 s1)
 304   (and (symbolp s0) (symbolp s1) (equal (symbol-name s0) (symbol-name s1))))
 305
 306 (defun geiser-syntax--scan-sexps (&optional begin)
 307   (let* ((fst (geiser-syntax--symbol-at-point))
 308          (smth (or fst (not (looking-at-p "[\s \s)\s>\s<\n]"))))
 309          (path (and fst `((,fst 0)))))
 310     (save-excursion
 311       (while (not (zerop (geiser-syntax--nesting-level)))
 312         (let ((boundary (point)))
 313           (geiser-syntax--skip-comment/string)
 314           (backward-up-list)
 315           (let ((form (geiser-syntax--shallow-form boundary)))
 316             (when (and (listp form) (car form) (symbolp (car form)))
 317               (let* ((len (geiser-syntax--pair-length form))
 318                      (pos (if smth (1- len) (progn (setq smth t) len)))
 319                      (prev (and (> pos 1) (nth (1- pos) form)))
 320                      (prev (and (geiser-syntax--keywordp prev)
 321                                 (list prev))))
 322                 (push `(,(car form) ,pos ,@prev) path)))))))
 323     (mapcar (lambda (e) (cons (format "%S" (car e)) (cdr e)))
 324             (nreverse path))))
 325
 326 (defsubst geiser-syntax--binding-form-p (bfs sbfs f)
 327   (and (symbolp f)
 328        (let ((f (symbol-name f)))
 329          (or (member f '("define" "define*" "define-syntax"
 330                          "syntax-rules" "lambda" "case-lambda"
 331                          "let" "let*" "let-values" "let*-values"
 332                          "letrec" "letrec*" "parameterize"))
 333              (member f bfs)
 334              (member f sbfs)))))
 335
 336 (defsubst geiser-syntax--binding-form*-p (sbfs f)
 337   (and (symbolp f)
 338        (let ((f (symbol-name f)))
 339          (or (member f '("let*" "let*-values" "letrec" "letrec*"))
 340              (member f sbfs)))))
 341
 342 (defsubst geiser-syntax--if-symbol (x) (and (symbolp x) x))
 343 (defsubst geiser-syntax--if-list (x) (and (listp x) x))
 344
 345 (defsubst geiser-syntax--normalize (vars)
 346   (mapcar (lambda (i)
 347             (let ((i (if (listp i) (car i) i)))
 348               (and (symbolp i) (symbol-name i))))
 349           vars))
 350
 351 (defun geiser-syntax--linearize (form)
 352   (cond ((not (listp form)) (list form))
 353         ((null form) nil)
 354         (t (cons (car form) (geiser-syntax--linearize (cdr form))))))
 355
 356 (defun geiser-syntax--scan-locals (bfs sbfs form nesting locals)
 357   (if (or (null form) (not (listp form)))
 358       (geiser-syntax--normalize locals)
 359     (if (not (geiser-syntax--binding-form-p bfs sbfs (car form)))
 360         (geiser-syntax--scan-locals bfs sbfs
 361                                     (car (last form))
 362                                     (1- nesting) locals)
 363       (let* ((head (car form))
 364              (name (geiser-syntax--if-symbol (cadr form)))
 365              (names (if name (geiser-syntax--if-list (caddr form))
 366                       (geiser-syntax--if-list (cadr form))))
 367              (bns (and name
 368                        (geiser-syntax--binding-form-p bfs sbfs (car names))))
 369              (rest (if (and name (not bns)) (cdddr form) (cddr form)))
 370              (use-names (and (or rest
 371                                  (< nesting 1)
 372                                  (geiser-syntax--binding-form*-p sbfs head))
 373                              (not bns))))
 374         (when name (push name locals))
 375         (when (geiser-syntax--symbol-eq head 'case-lambda)
 376           (dolist (n (and (> nesting 0) (caar (last form))))
 377             (when n (push n locals)))
 378           (setq rest (and (> nesting 0) (cdr form)))
 379           (setq use-names nil))
 380         (when (geiser-syntax--symbol-eq head 'syntax-rules)
 381           (dolist (n (and (> nesting 0) (cdaar (last form))))
 382             (when n (push n locals)))
 383           (setq rest (and (> nesting 0) (cdr form))))
 384         (when use-names
 385           (dolist (n (geiser-syntax--linearize names))
 386             (let ((xs (if (and (listp n) (listp (car n))) (car n) (list n))))
 387               (dolist (x xs) (when x (push x locals))))))
 388         (dolist (f (butlast rest))
 389           (when (and (listp f)
 390                      (geiser-syntax--symbol-eq (car f) 'define)
 391                      (cadr f))
 392             (push (cadr f) locals)))
 393         (geiser-syntax--scan-locals bfs sbfs
 394                                     (car (last (or rest names)))
 395                                     (1- nesting)
 396                                     locals)))))
 397
 398 (defun geiser-syntax--locals-around-point (bfs sbfs)
 399   (when (eq major-mode 'scheme-mode)
 400     (save-excursion
 401       (let ((sym (unless (geiser-syntax--skip-comment/string)
 402                    (thing-at-point 'symbol))))
 403         (skip-syntax-forward "->")
 404         (let ((boundary (point))
 405               (nesting (geiser-syntax--nesting-level)))
 406           (while (not (zerop (geiser-syntax--nesting-level)))
 407             (backward-up-list))
 408           (multiple-value-bind (form end)
 409               (geiser-syntax--form-after-point boundary)
 410             (delete sym
 411                     (geiser-syntax--scan-locals bfs
 412                                                 sbfs
 413                                                 form
 414                                                 (1- nesting)
 415                                                 '()))))))))
 416
 417 \f
 418 ;;; Fontify strings as Scheme code:
 419
 420 (defun geiser-syntax--font-lock-buffer ()
 421   (let ((name " *geiser font lock*"))
 422     (or (get-buffer name)
 423         (let ((buffer (get-buffer-create name)))
 424           (set-buffer buffer)
 425           (let ((geiser-default-implementation
 426                  (or geiser-default-implementation
 427                      (car geiser-active-implementations))))
 428             (scheme-mode))
 429           buffer))))
 430
 431 (defun geiser-syntax--scheme-str (str)
 432   (save-current-buffer
 433     (set-buffer (geiser-syntax--font-lock-buffer))
 434     (erase-buffer)
 435     (insert str)
 436     (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
 437     (buffer-string)))
 438
 439 \f
 440 (provide 'geiser-syntax)
 441 ;;; geiser-syntax.el ends here