(require 'slime)
(require 'slime-c-p-c)
(require 'slime-parse)

(defvar slime-package-fu-init-undo-stack nil)

(define-slime-contrib slime-package-fu
  "Exporting/Unexporting symbols at point."
  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
  (:license "GPL")
  (:swank-dependencies swank-package-fu)
  (:on-load
   (push `(progn (define-key slime-mode-map "\C-cx"
                   ',(lookup-key slime-mode-map "\C-cx")))
         slime-package-fu-init-undo-stack)
   (define-key slime-mode-map "\C-cx"  'slime-export-symbol-at-point))
  (:on-unload
   (while slime-c-p-c-init-undo-stack
     (eval (pop slime-c-p-c-init-undo-stack)))))

(defvar slime-package-file-candidates
  (mapcar #'file-name-nondirectory
          '("package.lisp" "packages.lisp" "pkgdcl.lisp"
            "defpackage.lisp")))

(defvar slime-export-symbol-representation-function
  #'(lambda (n) (format "#:%s" n)))

(defvar slime-export-symbol-representation-auto t
  "Determine automatically which style is used for symbols, #: or :
If it's mixed or no symbols are exported so far,
use `slime-export-symbol-representation-function'.")

(defvar slime-export-save-file nil
  "Save the package file after each automatic modification")

(defvar slime-defpackage-regexp
  "^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*")

(defun slime-find-package-definition-rpc (package)
  (slime-eval `(swank:find-definition-for-thing
                (swank::guess-package ,package))))

(defun slime-find-package-definition-regexp (package)
  (save-excursion
    (save-match-data
      (goto-char (point-min))
      (cl-block nil
        (while (re-search-forward slime-defpackage-regexp nil t)
          (when (slime-package-equal package (slime-sexp-at-point))
            (backward-sexp)
            (cl-return (make-slime-file-location (buffer-file-name)
                                                 (1- (point))))))))))

(defun slime-package-equal (designator1 designator2)
  ;; First try to be lucky and compare the strings themselves (for the
  ;; case when one of the designated packages isn't loaded in the
  ;; image.) Then try to do it properly using the inferior Lisp which
  ;; will also resolve nicknames for us &c.
  (or (cl-equalp (slime-cl-symbol-name designator1)
                 (slime-cl-symbol-name designator2))
      (slime-eval `(swank:package= ,designator1 ,designator2))))

(defun slime-export-symbol (symbol package)
  "Unexport `symbol' from `package' in the Lisp image."
  (slime-eval `(swank:export-symbol-for-emacs ,symbol ,package)))

(defun slime-unexport-symbol (symbol package)
  "Export `symbol' from `package' in the Lisp image."
  (slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package)))


(defun slime-find-possible-package-file (buffer-file-name)
  (cl-labels ((file-name-subdirectory (dirname)
                                      (expand-file-name
                                       (concat (file-name-as-directory (slime-to-lisp-filename dirname))
                                               (file-name-as-directory ".."))))
              (try (dirname)
                   (cl-dolist (package-file-name slime-package-file-candidates)
                     (let ((f (slime-to-lisp-filename
                               (concat dirname package-file-name))))
                       (when (file-readable-p f)
                         (cl-return f))))))
    (when buffer-file-name
      (let ((buffer-cwd (file-name-directory buffer-file-name)))
        (or (try buffer-cwd)
            (try (file-name-subdirectory buffer-cwd))
            (try (file-name-subdirectory
                  (file-name-subdirectory buffer-cwd))))))))

(defun slime-goto-package-source-definition (package)
  "Tries to find the DEFPACKAGE form of `package'. If found,
places the cursor at the start of the DEFPACKAGE form."
  (cl-labels ((try (location)
                   (when (slime-location-p location)
                     (slime-goto-source-location location)
                     t)))
    (or (try (slime-find-package-definition-rpc package))
        (try (slime-find-package-definition-regexp package))
        (try (let ((package-file (slime-find-possible-package-file
                                  (buffer-file-name))))
               (when package-file
                 (with-current-buffer (find-file-noselect package-file t)
                   (slime-find-package-definition-regexp package)))))
        (error "Couldn't find source definition of package: %s" package))))

(defun slime-at-expression-p (pattern)
  (when (ignore-errors
          ;; at a list?
          (= (point) (progn (down-list 1)
                            (backward-up-list 1)
                            (point))))
    (save-excursion
      (down-list 1)
      (slime-in-expression-p pattern))))

(defun slime-goto-next-export-clause ()
  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
  (let ((point))
    (save-excursion
      (cl-block nil
        (while (ignore-errors (slime-forward-sexp) t)
          (skip-chars-forward " \n\t")
          (when (slime-at-expression-p '(:export *))
            (setq point (point))
            (cl-return)))))
    (if point
        (goto-char point)
      (error "No next (:export ...) clause found"))))

(defun slime-search-exports-in-defpackage (symbol-name)
  "Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
  (cl-labels ((target-symbol-p (symbol)
                               (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
                                                       (regexp-quote symbol-name))
                                               symbol)))
    (save-excursion
      (cl-block nil
        (while (ignore-errors (slime-goto-next-export-clause) t)
          (let ((clause-end (save-excursion (forward-sexp) (point))))
            (save-excursion
              (while (search-forward symbol-name clause-end t)
                (when (target-symbol-p (slime-symbol-at-point))
                  (cl-return (if (slime-inside-string-p)
                                 ;; Include the following "
                                 (1+ (point))
                               (point))))))))))))

(defun slime-export-symbols ()
  "Return a list of symbols inside :export clause of a defpackage."
  ;; Assumes we're at the beginning of :export
  (cl-labels ((read-sexp ()
                         (ignore-errors
                           (forward-comment (point-max))
                           (buffer-substring-no-properties
                            (point) (progn (forward-sexp) (point))))))
    (save-excursion
      (cl-loop for sexp = (read-sexp) while sexp collect sexp))))

(defun slime-defpackage-exports ()
  "Return a list of symbols inside :export clause of a defpackage."
  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
  (cl-labels ((normalize-name (name)
                              (if (string-prefix-p "\"" name)
                                  (read name)
                                (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
                                                          "" name))))
    (save-excursion
      (mapcar #'normalize-name
              (cl-loop while (ignore-errors (slime-goto-next-export-clause) t)
                       do (down-list) (forward-sexp)
                       append (slime-export-symbols)
                       do (up-list) (backward-sexp))))))

(defun slime-symbol-exported-p (name symbols)
  (cl-member name symbols :test 'cl-equalp))

(defun slime-frob-defpackage-form (current-package do-what symbols)
  "Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
depending on the value of `do-what' which can either be `:export',
or `:unexport'.

Returns t if the symbol was added/removed. Nil if the symbol was
already exported/unexported."
  (save-excursion
    (slime-goto-package-source-definition current-package)
    (down-list 1)                       ; enter DEFPACKAGE form
    (forward-sexp)                      ; skip DEFPACKAGE symbol
    ;; Don't or will fail if (:export ...) is immediately following
    ;; (forward-sexp)                   ; skip package name
    (let ((exported-symbols (slime-defpackage-exports))
          (symbols (if (consp symbols)
                       symbols
                     (list symbols)))
          (number-of-actions 0))
      (cl-ecase do-what
        (:export
         (slime-add-export)
         (dolist (symbol symbols)
           (let ((symbol-name (slime-cl-symbol-name symbol)))
             (unless (slime-symbol-exported-p symbol-name exported-symbols)
               (cl-incf number-of-actions)
               (slime-insert-export symbol-name)))))
        (:unexport
         (dolist (symbol symbols)
           (let ((symbol-name (slime-cl-symbol-name symbol)))
             (when (slime-symbol-exported-p symbol-name exported-symbols)
               (slime-remove-export symbol-name)
               (cl-incf number-of-actions))))))
      (when slime-export-save-file
        (save-buffer))
      number-of-actions)))

(defun slime-add-export ()
  (let (point)
    (save-excursion
      (while (ignore-errors (slime-goto-next-export-clause) t)
        (setq point (point))))
    (cond (point
           (goto-char point)
           (down-list)
           (slime-end-of-list))
          (t
           (slime-end-of-list)
           (unless (looking-back "^\\s-*")
             (newline-and-indent))
           (insert "(:export ")
           (save-excursion (insert ")"))))))

(defun slime-determine-symbol-style ()
  ;; Assumes we're inside :export
  (save-excursion
    (slime-beginning-of-list)
    (slime-forward-sexp)
    (let ((symbols (slime-export-symbols)))
      (cond ((null symbols)
             slime-export-symbol-representation-function)
            ((cl-every (lambda (x)
                         (string-match "^:" x))
                       symbols)
             (lambda (n) (format ":%s" n)))
            ((cl-every (lambda (x)
                         (string-match "^#:" x))
                       symbols)
             (lambda (n) (format "#:%s" n)))
            ((cl-every (lambda (x)
                         (string-prefix-p "\"" x))
                       symbols)
             (lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
            (t
             slime-export-symbol-representation-function)))))

(defun slime-format-symbol-for-defpackage (symbol-name)
  (funcall (if slime-export-symbol-representation-auto
               (slime-determine-symbol-style)
             slime-export-symbol-representation-function)
           symbol-name))

(defun slime-insert-export (symbol-name)
  ;; Assumes we're at the inside :export after the last symbol
  (let ((symbol-name (slime-format-symbol-for-defpackage symbol-name)))
    (unless (looking-back "^\\s-*")
      (newline-and-indent))
    (insert symbol-name)))

(defun slime-remove-export (symbol-name)
  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
  (let ((point))
    (while (setq point (slime-search-exports-in-defpackage symbol-name))
      (save-excursion
        (goto-char point)
        (backward-sexp)
        (delete-region (point) point)
        (beginning-of-line)
        (when (looking-at "^\\s-*$")
          (join-line)
          (delete-trailing-whitespace (point) (line-end-position)))))))

(defun slime-export-symbol-at-point ()
  "Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
  (interactive)
  (let ((package (slime-current-package))
        (symbol (slime-symbol-at-point)))
    (unless symbol (error "No symbol at point."))
    (cond (current-prefix-arg
           (if (cl-plusp (slime-frob-defpackage-form package :unexport symbol))
               (message "Symbol `%s' no longer exported form `%s'"
                        symbol package)
             (message "Symbol `%s' is not exported from `%s'"
                      symbol package))
           (slime-unexport-symbol symbol package))
          (t
           (if (cl-plusp (slime-frob-defpackage-form package :export symbol))
               (message "Symbol `%s' now exported from `%s'"
                        symbol package)
             (message "Symbol `%s' already exported from `%s'"
                      symbol package))
           (slime-export-symbol symbol package)))))

(defun slime-export-class (name)
  "Export acessors, constructors, etc. associated with a structure or a class"
  (interactive (list (slime-read-from-minibuffer "Export structure named: "
                                                 (slime-symbol-at-point))))
  (let* ((package (slime-current-package))
         (symbols (slime-eval `(swank:export-structure ,name ,package))))
    (message "%s symbols exported from `%s'"
             (slime-frob-defpackage-form package :export symbols)
             package)))

(defalias 'slime-export-structure 'slime-export-class)

(provide 'slime-package-fu)

;; Local Variables:
;; indent-tabs-mode: nil
;; End: