[nongnu] elpa/haskell-tng-mode e3c6dc6 336/385: follow re-exports

[ELPA Syncer]

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

    follow re-exports
---
 haskell-tng-hsinspect.el | 68 ++++++++++++++++++++++++++++++++----------------
 1 file changed, 46 insertions(+), 22 deletions(-)

diff --git a/haskell-tng-hsinspect.el b/haskell-tng-hsinspect.el
index 37fbf09..339a124 100644
--- a/haskell-tng-hsinspect.el
+++ b/haskell-tng-hsinspect.el
@@ -58,10 +58,12 @@ TODO: support local / git packages by consulting 
`plan.json'"
               ;; TODO imports and index can be calculated in parallel
               (sym (haskell-tng--hsinspect-symbol-at-point))
               (found (haskell-tng--hsinspect-qualify imports sym))
+              ;; TODO pcase would be better here
               (parts (haskell-tng--string-split-last found "."))
-              (module (car parts))
               (name (cdr parts))
-              (srcid (haskell-tng--hsinspect-find-srcid index module))
+              (followed (haskell-tng--hsinspect-follow index nil (car parts) 
name))
+              (srcid (car followed))
+              (module (cdr followed))
               (tarball (haskell-tng--hsinspect-srcid-source srcid))
               (file (concat
                      ;; TODO string-replace would be nice...
@@ -73,11 +75,11 @@ TODO: support local / git packages by consulting 
`plan.json'"
       ;; code, so no point looking.
       ;;
       ;; WORKAROUND https://github.com/haskell/cabal/issues/6443
+      ;; TODO curl or a built-in emacs downloader, so cabal is not necessary
       (shell-command (format "cabal get %s -d /var/empty &" srcid))
       (error "%s was not found, attempting to download: please try again 
later" tarball))
 
     (message "Loading %s from %s" sym tarball)
-    ;; TODO follow re-exports
     (find-file tarball)
     (let ((archive (current-buffer)))
       (goto-char (point-min))
@@ -86,12 +88,10 @@ TODO: support local / git packages by consulting 
`plan.json'"
       (kill-buffer archive)
       (read-only-mode 1)
       (goto-char (point-min))
-      ;; TODO re-use the imenu top-level parser
-      ;; avoid false positives in export lists
+      ;; TODO re-use the imenu top-level parser, this is a massive hack
       (re-search-forward (rx line-start "import" word-end) nil t)
-      ;; will unfortunately find first uses
       (or
-       (re-search-forward (rx-to-string `(: (| bol "| " "data " "type " "class 
") ,name symbol-end)))
+       (re-search-forward (rx-to-string `(: (| bol "| " "data " "type " "class 
") ,name symbol-end)) nil t)
        (re-search-forward (rx-to-string `(: symbol-start ,name 
symbol-end)))))))
 
 (defun haskell-tng--string-split-last (str sep)
@@ -103,26 +103,13 @@ TODO: support local / git packages by consulting 
`plan.json'"
     (cons front back)))
 
 (defun haskell-tng--hsinspect-srcid-source (srcid)
+  (message "[haskell-tng] [DEBUG] tarball %s" srcid)
   (let* ((parts (haskell-tng--string-split-last srcid "-"))
          (package (car parts))
          (version (cdr parts)))
     (expand-file-name
      (concat "~/.cabal/packages/hackage.haskell.org/" package "/" version "/" 
srcid ".tar.gz"))))
 
-;; TODO expose the inplace information instead of filtering
-(defun haskell-tng--hsinspect-find-srcid (index module)
-  ;; requires 0.0.9+
-  (alist-get
-   'srcid
-   (seq-find
-    (lambda (pkg-entry)
-      (when (not (alist-get 'inplace pkg-entry))
-        (seq-find
-         (lambda (module-entry)
-           (equal module (alist-get 'module module-entry)))
-         (alist-get 'modules pkg-entry))))
-    index)))
-
 ;; TODO haskell-tng-show-documentation
 
 (defvar-local haskell-tng-hsinspect-as
@@ -163,7 +150,7 @@ Respects the `C-u' cache invalidation convention."
         (flush-cache (and alt (not (eq '- alt)))))
     (when-let ((index (haskell-tng--hsinspect-index flush-cache))
                (sym (haskell-tng--hsinspect-symbol-at-point)))
-      (message "Seaching for '%s' in %s modules" sym (length index))
+      (message "Searching for '%s' in %s packages" sym (length index))
 
       (when (string-match (rx bos (group (+ anything)) "." (group (+ (not (any 
".")))) eos) sym)
         (setq qual (match-string 1 sym))
@@ -247,6 +234,43 @@ Respects the `C-u' cache invalidation convention."
      (lambda (names) (member sym (seq-map #'cdr names)))
      imports))))
 
+(defun haskell-tng--hsinspect-follow (index srcid module name)
+  "Follow re-exports of MODULE to find which (srcid . module)
+originally defined NAME.
+
+The original module may not be exported and is therefore not
+present in the index. If an unexported module exports another
+unexported module's definition, we are unable to locate it."
+  ;; TODO probably doesn't work for 'tycon
+  ;; TODO use seq-find instead of seq-mapcat
+  ;; TODO `hsinspect index' could include unexported modules
+  (when srcid
+    (message "[haskell-tng] [DEBUG] follow %s %s %s" srcid module name))
+  (or
+   (car
+    (seq-mapcat
+     (lambda (pkg-entry)
+       (let ((srcid_ (alist-get 'srcid pkg-entry)))
+         (when (or (null srcid) (equal srcid srcid_))
+           (seq-mapcat
+            (lambda (module-entry)
+              (when (equal module (alist-get 'module module-entry))
+                (seq-mapcat
+                 (lambda (entry)
+                   (let ((id (pcase (alist-get 'class entry)
+                               ((or 'id 'con 'pat) (alist-get 'name entry))
+                               ('tycon (alist-get 'type entry)))))
+                     (when (equal id name)
+                       (if-let* ((export (alist-get 'export entry))
+                                 (from (alist-get 'module export))
+                                 (pkg (or (alist-get 'srcid export) srcid_)))
+                           (list (haskell-tng--hsinspect-follow index pkg from 
name))
+                         (list (cons srcid_ module))))))
+                 (alist-get 'ids module-entry))))
+            (alist-get 'modules pkg-entry)))))
+     index))
+   (cons srcid module)))
+
 (defun haskell-tng--hsinspect-import-popup (index sym)
   (when-let ((hits (haskell-tng--hsinspect-import-candidates index sym)))
     ;; TODO special case one hit