elisp/geiser-syntax.el

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