branch: elpa/idris-mode
commit 1856fdb4bfd700d9593a6598f24c5b00ef05f250
Merge: b264cbf643 73c718af17
Author: Jan de Muijnck-Hughes <j...@users.noreply.github.com>
Commit: GitHub <nore...@github.com>
Merge pull request #634 from keram/idris-filename-to-load-v2
Improve `idris-filename-to-load` to return expected pair of dir and
relative path depending on idris-protocol version
---
idris-commands.el | 16 ++++++++--------
idris-compat.el | 23 +++++++++++++++++++++++
test/idris-commands-test.el | 40 ++++++++++++++++++++++++++++++++++++++++
3 files changed, 71 insertions(+), 8 deletions(-)
diff --git a/idris-commands.el b/idris-commands.el
index f8fd61c8df..1003a6d8ff 100644
--- a/idris-commands.el
+++ b/idris-commands.el
@@ -168,14 +168,14 @@
(defun idris-filename-to-load ()
"Compute the working directory and filename to load in Idris.
Returning these as a cons."
- (let* ((fn (buffer-file-name))
- (ipkg-srcdir (idris-ipkg-find-src-dir))
- (srcdir (or ipkg-srcdir (file-name-directory fn))))
- (when (and ;; check that srcdir is prefix of filename - then load relative
- (> (length fn) (length srcdir))
- (string= (substring fn 0 (length srcdir)) srcdir))
- (setq fn (file-relative-name fn srcdir)))
- (cons srcdir fn)))
+ (let* ((ipkg-file (car-safe (idris-find-file-upwards "ipkg")))
+ (file-name (buffer-file-name))
+ (work-dir (directory-file-name (idris-file-name-parent-directory (or
ipkg-file file-name))))
+ (source-dir (or (idris-ipkg-find-src-dir) work-dir)))
+ ;; TODO: Update once https://github.com/idris-lang/Idris2/issues/3310 is
resolved
+ (if (> idris-protocol-version 1)
+ (cons work-dir (file-relative-name file-name work-dir))
+ (cons source-dir (file-relative-name file-name source-dir)))))
(defun idris-load-file (&optional set-line)
"Pass the current buffer's file to the inferior Idris process.
diff --git a/idris-compat.el b/idris-compat.el
index d248d7f872..845cfc9e91 100644
--- a/idris-compat.el
+++ b/idris-compat.el
@@ -41,5 +41,28 @@ attention to case differences."
(concat (apply 'concat (mapcar 'file-name-as-directory dirs))
(car (reverse components))))))
+(if (fboundp 'file-name-parent-directory)
+ (defalias 'idris-file-name-parent-directory 'file-name-parent-directory)
+ ;; Extracted from Emacs 29+
https://github.com/emacs-mirror/emacs/blob/master/lisp/files.el
+ (defun idris-file-name-parent-directory (filename)
+ "Return the directory name of the parent directory of FILENAME.
+If FILENAME is at the root of the filesystem, return nil.
+If FILENAME is relative, it is interpreted to be relative
+to `default-directory', and the result will also be relative."
+ (let* ((expanded-filename (expand-file-name filename))
+ (parent (file-name-directory (directory-file-name
expanded-filename))))
+ (cond
+ ;; filename is at top-level, therefore no parent
+ ((or (null parent)
+ ;; `equal' is enough, we don't need to resolve symlinks here
+ ;; with `file-equal-p', also for performance
+ (equal parent expanded-filename))
+ nil)
+ ;; filename is relative, return relative parent
+ ((not (file-name-absolute-p filename))
+ (file-relative-name parent))
+ (t
+ parent)))))
+
(provide 'idris-compat)
;;; idris-compat.el ends here
diff --git a/test/idris-commands-test.el b/test/idris-commands-test.el
index e37bb72f13..020b13f4cc 100644
--- a/test/idris-commands-test.el
+++ b/test/idris-commands-test.el
@@ -426,6 +426,46 @@ closeDistance s1 s2 = closeDistance_rhs s1 s2"
(advice-remove 'idris-load-file-sync #'idris-load-file-sync-stub)
(advice-remove 'idris-eval #'idris-eval-stub))))
+(ert-deftest idris-test-idris-filename-to-load ()
+ "Test that `idris-filename-to-load' returns expected data structure."
+ (cl-flet ((idris-ipkg-find-src-dir-stub () src-dir)
+ (idris-find-file-upwards-stub (_ex) ipkg-files)
+ (buffer-file-name-stub ()
"/some/path/to/idris-project/src/Component/Foo.idr"))
+ (advice-add 'idris-ipkg-find-src-dir :override
#'idris-ipkg-find-src-dir-stub)
+ (advice-add 'idris-find-file-upwards :override
#'idris-find-file-upwards-stub)
+ (advice-add 'buffer-file-name :override #'buffer-file-name-stub)
+ (let* ((default-directory "/some/path/to/idris-project/src/Component")
+ ipkg-files
+ src-dir)
+ (unwind-protect
+ (progn
+ (let ((result (idris-filename-to-load)))
+ (should (equal default-directory (car result)))
+ (should (equal "Foo.idr" (cdr result))))
+
+ ;; When ipkg sourcedir value is set
+ ;; Then return combination of source directory
+ ;; and relative path of the file to the source directory
+ (let* ((src-dir "/some/path/to/idris-project/src")
+ (result (idris-filename-to-load)))
+ (should (equal src-dir (car result)))
+ (should (equal "Component/Foo.idr" (cdr result))))
+
+ ;; When ipkg sourcedir value is set
+ ;; and idris-protocol-version is greater than 1
+ ;; Then return combination of work directory
+ ;; (Directory containing the first found ipkg file)
+ ;; and relative path of the file to the work directory
+ (let* ((ipkg-files '("/some/path/to/idris-project/baz.ipkg"))
+ (idris-protocol-version 2)
+ (result (idris-filename-to-load)))
+ (should (equal "/some/path/to/idris-project" (car result)))
+ (should (equal "src/Component/Foo.idr" (cdr result)))))
+
+ (advice-remove 'idris-ipkg-find-src-dir #'idris-ipkg-find-src-dir-stub)
+ (advice-remove 'idris-find-file-upwards #'idris-find-file-upwards-stub)
+ (advice-remove 'buffer-file-name #'buffer-file-name-stub)))))
+
;; Tests by Yasuhiko Watanabe
;; https://github.com/idris-hackers/idris-mode/pull/537/files
(idris-ert-command-action "test-data/CaseSplit.idr" idris-case-split
idris-test-eq-buffer)
