;;; geiser-syntax.el -- utilities for parsing scheme syntax

;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.

;; Start date: Sun Feb 08, 2009 15:03



(require 'geiser-impl)
(require 'geiser-popup)
(require 'geiser-base)

(require 'scheme)


;;; Indentation:

(defmacro geiser-syntax--scheme-indent (&rest pairs)
  `(progn ,@(mapcar (lambda (p)
                      `(put ',(car p) 'scheme-indent-function ',(cadr p)))
                    pairs)))

(geiser-syntax--scheme-indent
 (begin0 1)
 (c-declare 0)
 (c-lambda 2)
 (case-lambda 0)
 (case-lambda: 0)
 (catch defun)
 (class defun)
 (class* defun)
 (compound-unit/sig 0)
 (define: defun)
 (dynamic-wind 0)
 (for/fold 2)
 (instantiate 2)
 (interface 1)
 (lambda: 1)
 (lambda/kw 1)
 (let*-values 1)
 (let*-values: 1)
 (let+ 1)
 (let: 1)
 (letrec: 1)
 (letrec* 1)
 (letrec-values 1)
 (letrec-values: 1)
 (let-values 1)
 (let-values: 1)
 (let/cc: 1)
 (let/ec 1)
 (match defun)
 (mixin 2)
 (module defun)
 (opt-lambda 1)
 (parameterize 1)
 (parameterize-break 1)
 (parameterize* 1)
 (pmatch defun)
 (quasisyntax/loc 1)
 (receive 2)
 (send* 1)
 (sigaction 1)
 (syntax-case 2)
 (syntax/loc 1)
 (type-case defun)
 (unit defun)
 (unit/sig 2)
 (unless 1)
 (when 1)
 (while 1)
 (with-fluid* 1)
 (with-fluids 1)
 (with-fluids* 1)
 (with-handlers 1)
 (with-handlers: 1)
 (with-method 1)
 (with-syntax 1))


;;; A simple scheme reader

(defvar geiser-syntax--read/buffer-limit nil)

(defsubst geiser-syntax--read/eos ()
  (or (eobp)
      (and geiser-syntax--read/buffer-limit
           (<= geiser-syntax--read/buffer-limit (point)))))

(defsubst geiser-syntax--read/next-char ()
  (unless (geiser-syntax--read/eos)
    (forward-char)
    (char-after)))

(defsubst geiser-syntax--read/token (token)
  (geiser-syntax--read/next-char)
  (if (listp token) token (list token)))

(defsubst geiser-syntax--read/elisp ()
  (ignore-errors (read (current-buffer))))

(defun geiser-syntax--read/matching (open close)
  (let ((count 1)
        (p (1+ (point))))
    (while (and (> count 0)
                (geiser-syntax--read/next-char))
      (cond ((looking-at-p open) (setq count (1+ count)))
            ((looking-at-p close) (setq count (1- count)))))
    (buffer-substring-no-properties p (point))))

(defsubst geiser-syntax--read/unprintable ()
  (geiser-syntax--read/token
   (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))

(defun geiser-syntax--read/skip-comment ()
  (while (and (geiser-syntax--read/next-char)
              (nth 8 (syntax-ppss))))
  (geiser-syntax--read/next-token))

(defun geiser-syntax--read/next-token ()
  (skip-syntax-forward "->")
  (if (geiser-syntax--read/eos) '(eob)
    (case (char-after)
      (?\; (geiser-syntax--read/skip-comment))
      ((?\( ?\[) (geiser-syntax--read/token 'lparen))
      ((?\) ?\]) (geiser-syntax--read/token 'rparen))
      (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
              (geiser-syntax--read/token 'dot)
            (cons 'atom (geiser-syntax--read/elisp))))
      (?\# (case (geiser-syntax--read/next-char)
             ('nil '(eob))
             (?| (geiser-syntax--read/skip-comment))
             (?: (if (geiser-syntax--read/next-char)
                     (cons 'kwd (geiser-syntax--read/elisp))
                   '(eob)))
             (?\\ (cons 'char (geiser-syntax--read/elisp)))
             (?\( (geiser-syntax--read/token 'vectorb))
             (?\< (geiser-syntax--read/unprintable))
             ((?' ?` ?,) (geiser-syntax--read/next-token))
             (t (let ((tok (geiser-syntax--read/elisp)))
                  (if tok (cons 'atom (intern (format "#%s" tok)))
                    (geiser-syntax--read/next-token))))))
      (?\' (geiser-syntax--read/token '(quote . quote)))
      (?\` (geiser-syntax--read/token
            `(backquote . ,backquote-backquote-symbol)))
      (?, (if (eq (geiser-syntax--read/next-char) ?@)
              (geiser-syntax--read/token
               `(splice . ,backquote-splice-symbol))
            `(unquote . ,backquote-unquote-symbol)))
      (?\" (cons 'string (geiser-syntax--read/elisp)))
      (t (cons 'atom (geiser-syntax--read/elisp))))))

(defsubst geiser-syntax--read/match (&rest tks)
  (let ((token (geiser-syntax--read/next-token)))
    (if (memq (car token) tks) token
      (error "Unexpected token: %s" token))))

(defsubst geiser-syntax--read/skip-until (&rest tks)
  (let (token)
    (while (and (not (memq (car token) tks))
                (not (eq (car token) 'eob)))
      (setq token (geiser-syntax--read/next-token)))
    token))

(defsubst geiser-syntax--read/try (&rest tks)
  (let ((p (point))
        (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
    (unless tk (goto-char p))
    tk))

(defun geiser-syntax--read/list ()
  (cond ((geiser-syntax--read/try 'dot)
         (let ((tail (geiser-syntax--read)))
           (geiser-syntax--read/skip-until 'eob 'rparen)
           tail))
        ((geiser-syntax--read/try 'rparen 'eob) nil)
        (t (cons (geiser-syntax--read)
                 (geiser-syntax--read/list)))))

(defun geiser-syntax--read ()
  (let ((token (geiser-syntax--read/next-token))
        (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
    (case (car token)
      (eob nil)
      (lparen (geiser-syntax--read/list))
      (vectorb (apply 'vector (geiser-syntax--read/list)))
      ((quote backquote unquote splice) (list (cdr token)
                                              (geiser-syntax--read)))
      (kwd (intern (format ":%s" (cdr token))))
      (unprintable (format "#<%s>" (cdr token)))
      ((char string atom) (cdr token))
      (t (error "Reading scheme syntax: unexpected token: %s" token)))))

(defun geiser-syntax--read-from-string (string &optional start end)
  (when (stringp string)
    (let* ((start (or start 0))
           (end (or end (length string)))
           (max-lisp-eval-depth (max max-lisp-eval-depth (- end start))))
      (with-temp-buffer
        (save-excursion (insert string))
        (cons (ignore-errors (geiser-syntax--read)) (point))))))

(defsubst geiser-syntax--form-after-point (&optional boundary)
  (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
    (save-excursion (values (geiser-syntax--read) (point)))))


;;; Code parsing:

(defsubst geiser-syntax--skip-comment/string ()
  (goto-char (or (nth 8 (syntax-ppss)) (point))))

(defsubst geiser-syntax--nesting-level ()
  (or (nth 0 (syntax-ppss)) 0))

(defsubst geiser-syntax--pair-length (p)
  (if (cdr (last p)) (1+ (safe-length p)) (length p)))

(defun geiser-syntax--scan-sexps (&optional begin)
  (let* ((fst (symbol-at-point))
         (smth (or fst (not (looking-at-p "[\\s \\s)\\s>\\s<\n]"))))
         (path (and fst `((,fst 0)))))
    (save-excursion
      (geiser-syntax--skip-comment/string)
      (while (not (zerop (geiser-syntax--nesting-level)))
        (let ((boundary (1+ (point))))
          (backward-up-list)
          (let ((form
                 (nth-value 0 (geiser-syntax--form-after-point boundary))))
            (when (and (listp form) (car form) (symbolp (car form)))
              (let* ((len (geiser-syntax--pair-length form))
                     (pos (if smth (1- len) (progn (setq smth t) len)))
                     (prev (and (> pos 1) (nth (1- pos) form)))
                     (prev (and (keywordp prev) (list prev))))
                (push `(,(car form) ,pos ,@prev) path)))))))
    (nreverse path)))

(defsubst geiser-syntax--binding-form-p (bfs sbfs f)
  (or (memq f '(define define* lambda let let* letrec))
      (memq f bfs)
      (memq f sbfs)))

(defsubst geiser-syntax--binding-form*-p (sbfs f)
  (or (eq 'let* f) (memq f sbfs)))

(defun geiser-syntax--scan-locals (bfs sbfs form partial locals)
  (flet ((if-symbol (x) (and (symbolp x) x))
         (if-list (x) (and (listp x) x))
         (normalize (vars) (mapcar (lambda (i) (if (listp i) (car i) i)) vars)))
    (let ((form (if (listp form) (normalize form) form)))
      (cond ((or (null form) (not (listp form))) (normalize locals))
            ((not (geiser-syntax--binding-form-p bfs sbfs (car form)))
             (geiser-syntax--scan-locals bfs sbfs
                                         (car (last form)) partial locals))
            (t
             (let* ((head (car form))
                    (name (if-symbol (cadr form)))
                    (names (if name (if-list (caddr form))
                             (if-list (cadr form))))
                    (rest (if name (cdddr form) (cddr form)))
                    (use-names (or rest
                                   (not partial)
                                   (geiser-syntax--binding-form*-p sbfs
                                                                   head))))
               (when name (push name locals))
               (when use-names (dolist (n names) (push n locals)))
               (dolist (f (butlast rest))
                 (when (and (listp f) (eq (car f) 'define))
                   (push (cadr f) locals)))
               (geiser-syntax--scan-locals bfs sbfs
                                           (car (last (or rest names)))
                                           partial
                                           locals)))))))

(defun geiser-syntax--locals-around-point (bfs sbfs)
  (when (eq major-mode 'scheme-mode)
    (save-excursion
      (geiser-syntax--skip-comment/string)
      (let ((boundary (point)))
        (while (not (zerop (geiser-syntax--nesting-level)))
          (backward-up-list))
        (multiple-value-bind (form end)
            (geiser-syntax--form-after-point boundary)
          (geiser-syntax--scan-locals bfs sbfs form (> end boundary) '()))))))


;;; Fontify strings as Scheme code:

(defun geiser-syntax--font-lock-buffer ()
  (let ((name " *geiser font lock*"))
    (or (get-buffer name)
        (let ((buffer (get-buffer-create name)))
          (set-buffer buffer)
          (let ((geiser-default-implementation
                 (or geiser-default-implementation
                     (car geiser-active-implementations))))
            (scheme-mode))
          buffer))))

(defun geiser-syntax--scheme-str (str)
  (save-current-buffer
    (set-buffer (geiser-syntax--font-lock-buffer))
    (erase-buffer)
    (insert str)
    (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
    (buffer-string)))


(provide 'geiser-syntax)
;;; geiser-syntax.el ends here