[nongnu] elpa/haskell-tng-mode b46dbd1 305/385: refactoring of the cache for more reuse later

[ELPA Syncer]

branch: elpa/haskell-tng-mode
commit b46dbd1084f6a7410ba43f8050f234a20396e0f3
Author: Tseen She <ts33n.sh3@gmail.com>
Commit: Tseen She <ts33n.sh3@gmail.com>

    refactoring of the cache for more reuse later
---
 haskell-tng-extra-company.el |  2 +-
 haskell-tng-hsinspect.el     | 69 +++++++++-----------------------------------
 haskell-tng-util.el          | 58 +++++++++++++++++++++++++++++++++++++
 3 files changed, 72 insertions(+), 57 deletions(-)

diff --git a/haskell-tng-extra-company.el b/haskell-tng-extra-company.el
index 8dc1f7d..54304d1 100644
--- a/haskell-tng-extra-company.el
+++ b/haskell-tng-extra-company.el
@@ -54,7 +54,7 @@
      ;;(message "TNG asked with %S" arg)
      (seq-mapcat
       (lambda (names) (all-completions arg (seq-map #'cdr names)))
-      (haskell-tng--hsinspect-imports nil nil)))
+      (haskell-tng--hsinspect-imports 'no-work nil)))
     ('sorted t)
     ('duplicates t)
     ;; TODO 'meta return the FQN
diff --git a/haskell-tng-hsinspect.el b/haskell-tng-hsinspect.el
index a3a46b4..c6b638b 100644
--- a/haskell-tng-hsinspect.el
+++ b/haskell-tng-hsinspect.el
@@ -15,7 +15,6 @@
 ;; with pre-canned data.
 
 (require 'subr-x)
-(require 'xdg)
 
 ;; Popups are not supported in stock Emacs so an extension is necessary:
 ;; https://emacs.stackexchange.com/questions/53373
@@ -37,7 +36,7 @@ A prefix argument ensures that caches are flushes."
   (if-let* ((sym (haskell-tng--hsinspect-symbol-at-point))
             (found (seq-find
                     (lambda (names) (member sym (seq-map #'cdr names)))
-                    (haskell-tng--hsinspect-imports 'allow-work alt))))
+                    (haskell-tng--hsinspect-imports nil alt))))
       ;; TODO multiple hits
       ;; TODO feedback when hsinspect is broken
       (popup-tip (format "%s" (cdar (last found))))
@@ -122,12 +121,13 @@ A prefix argument ensures that caches are flushes."
 (defvar-local haskell-tng--hsinspect-imports nil
   "Cache for the last `imports' call for this buffer.
 t means the process failed.")
-(defun haskell-tng--hsinspect-imports (allow-work flush-cache)
-  (haskell-tng--hsinspect-cached-cmd
-   'haskell-tng--hsinspect-imports
-   (concat buffer-file-name "." "imports")
+(defun haskell-tng--hsinspect-imports (no-work flush-cache)
+  (haskell-tng--hsinspect-cached
+   #'haskell-tng--hsinspect
    `("imports" ,buffer-file-name)
-   allow-work
+   'haskell-tng--hsinspect-imports
+   (concat "hsinspect-0.0.7" buffer-file-name "." "imports")
+   no-work
    flush-cache))
 
 (defvar-local haskell-tng--hsinspect-index nil
@@ -136,58 +136,15 @@ t means the process failed.")
 (defun haskell-tng--hsinspect-index (flush-cache)
   (when-let (ghcflags-dir
              (locate-dominating-file default-directory ".ghc.flags"))
-    (haskell-tng--hsinspect-cached-cmd
-     'haskell-tng--hsinspect-index
-     (concat (expand-file-name ghcflags-dir) ".index")
+    (haskell-tng--hsinspect-cached
+     #'haskell-tng--hsinspect
      '("index")
-     t
+     'haskell-tng--hsinspect-index
+     (concat "hsinspect-0.0.7" (expand-file-name ghcflags-dir) "index")
+     nil
      flush-cache)))
 
-(defun haskell-tng--hsinspect-cached-cmd (buffer-local-cache
-                                          disk-cache
-                                          args
-                                          allow-work flush-cache)
-  (when flush-cache
-    (set buffer-local-cache nil))
-  (when (not (symbol-value buffer-local-cache))
-    (let ((cache-file-name
-           (concat
-            (xdg-cache-home) "/"
-            "hsinspect-0.0.7/"
-            disk-cache)))
-      ;; user is responsible for flushing caches.
-      (when (and flush-cache (file-exists-p cache-file-name))
-        (delete-file cache-file-name))
-      (if (file-exists-p cache-file-name)
-          (set
-           buffer-local-cache
-           (progn
-             ;; TODO decide if we want to keep this check, it's mostly for 
debugging
-             (if (or
-                    (buffer-modified-p)
-                    (time-less-p
-                     (file-attribute-modification-time (file-attributes 
cache-file-name))
-                     (file-attribute-modification-time (file-attributes 
buffer-file-name))))
-                 (message "loading hsinspect cache older than the current 
buffer")
-               (message "loading hsinspect cache"))
-             (with-temp-buffer
-               (insert-file-contents cache-file-name)
-               (goto-char (point-min))
-               (ignore-errors (read (current-buffer))))))
-        (unless (or (not allow-work)
-                    (eq t (symbol-value buffer-local-cache)))
-          (set buffer-local-cache t)
-          (set buffer-local-cache (apply #'haskell-tng--hsinspect args))
-          (let ((cache (symbol-value buffer-local-cache)))
-            (unless (eq t cache)
-              (with-temp-file cache-file-name
-                (make-directory (file-name-directory cache-file-name) t)
-                (prin1 cache (current-buffer)))))))))
-
-  (when (not (eq t (symbol-value buffer-local-cache)))
-    (symbol-value buffer-local-cache)))
-
-;; TODO cache per project (or package at least)
+;; FIXME use a cache
 (defvar-local haskell-tng--hsinspect-exe nil)
 (defvar haskell-tng--hsinspect-which-hsinspect
   "cabal exec -v0 which -- hsinspect")
diff --git a/haskell-tng-util.el b/haskell-tng-util.el
index 96bd3f0..d7f93a8 100644
--- a/haskell-tng-util.el
+++ b/haskell-tng-util.el
@@ -12,6 +12,7 @@
 ;; TODO move things to single use sites (twas premature abstraction!)
 
 (require 'subr-x)
+(require 'xdg)
 
 (defun haskell-tng--util-paren-close (&optional pos)
   "The next `)', if it closes `POS's paren depth."
@@ -94,5 +95,62 @@ and taking a regexp."
        (concat "qualified " module " as " as)))
      "\n")))
 
+;; TODO needs a unit test
+;; TODO a macro that expands out the local variable
+(defun haskell-tng--hsinspect-cached
+    (fn args local disk &optional no-work flush-cache)
+  "A two-tier cache over a FN that takes ARGS.
+The caller is responsible for flushing the cache.
+
+If the LOCAL reference contains a cache of a previous call, it is
+returned immediately.
+
+If DISK expands to a file that exists in the cache directory, it
+is read as an s-expression, saved to LOCAL, and returned.
+
+Otherwise FN is called with ARGS and saved to both LOCAL and
+DISK.
+
+Errors are not cached, nil return values are cached.
+
+NO-WORK skips FN and only queries the caches.
+
+FLUSH-CACHE forces both LOCAL and DISK to be invalidated."
+  (when flush-cache
+    (set local nil))
+  (when (not (symbol-value local))
+    (let ((cache-file-name
+           (concat (xdg-cache-home) "/" disk)))
+      (when (and flush-cache (file-exists-p cache-file-name))
+        (delete-file cache-file-name))
+      (if (file-exists-p cache-file-name)
+          (set
+           local
+           (progn
+             ;; TODO remove this check, it's just for debugging
+             (if (or
+                  (buffer-modified-p)
+                  (time-less-p
+                   (file-attribute-modification-time (file-attributes 
cache-file-name))
+                   (file-attribute-modification-time (file-attributes 
buffer-file-name))))
+                 (message "loading %S cache older than the current buffer" 
(car args))
+               (message "loading %S cache" (car args)))
+             (with-temp-buffer
+               (insert-file-contents cache-file-name)
+               (goto-char (point-min))
+               (ignore-errors (read (current-buffer))))))
+        (unless (or no-work
+                    (eq 'cached-nil (symbol-value local)))
+          (set local 'cached-nil)
+          (set local (apply fn args))
+          (unless local (set local 'cached-nil))
+          (let ((cache (symbol-value local)))
+            (with-temp-file cache-file-name
+              (make-directory (file-name-directory cache-file-name) 
'create-parents)
+              (prin1 cache (current-buffer))))))))
+
+  (when (not (eq 'cached-nil (symbol-value local)))
+    (symbol-value local)))
+
 (provide 'haskell-tng-util)
 ;;; haskell-tng-util.el ends here