hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

M-C-d now can display the doc even in the sandbox.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-03-28 12:55:17 +09:00
parent 955b1b4091
commit 87926e699b
1 changed files with 32 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
elisp/ghc-doc.el
View File

@ -15,61 +15,47 @@
(defun ghc-browse-document (&optional haskell-org) (defun ghc-browse-document (&optional haskell-org)
(interactive "P") (interactive "P")
(let ((mod0 (ghc-extract-module)) (let ((mod0 (ghc-extract-module))
(expr0 (ghc-things-at-point))) (expr0 (ghc-things-at-point))
(cond pkg-ver-path mod expr info)
((and (not mod0) expr0) (if (or mod0 (not expr0))
(let* ((expr (ghc-read-expression expr0)) (setq mod (ghc-read-module-name mod0))
(info (ghc-get-info expr0)) (setq expr (ghc-read-expression expr0))
(mod (ghc-extact-module-from-info info)) (setq info (ghc-get-info expr0))
(pkg (ghc-resolve-package-name mod))) (setq mod (ghc-extact-module-from-info info)))
(if (and pkg mod) (setq pkg-ver-path (ghc-resolve-document-path mod))
(ghc-display-document pkg mod haskell-org expr) (if (and pkg-ver-path mod)
(ghc-display-document pkg-ver-path mod haskell-org expr)
(message "No document found")))) (message "No document found"))))
(t
(let* ((mod (ghc-read-module-name mod0))
(pkg (ghc-resolve-package-name mod)))
(if (and pkg mod)
(ghc-display-document pkg mod haskell-org)
(message "No document found")))))))
(defun ghc-resolve-package-name (mod) (ghc-defstruct pkg-ver-path pkg ver path)
(defun ghc-resolve-document-path (mod)
(with-temp-buffer (with-temp-buffer
(ghc-call-process "ghc-pkg" nil t nil "find-module" "--simple-output" mod) (ghc-call-process "ghc-mod" nil t nil "doc" mod)
(goto-char (point-min)) (goto-char (point-min))
(when (re-search-forward "\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\)$" nil t) (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")
(ghc-make-pkg-ver (ghc-make-pkg-ver-path
:pkg (match-string-no-properties 1) :pkg (match-string-no-properties 1)
:ver (match-string-no-properties 2))))) :ver (match-string-no-properties 2)
:path (match-string-no-properties 4)))))
(defun ghc-resolve-document-path (pkg)
(with-temp-buffer
(ghc-call-process "ghc-pkg" nil t nil "field" pkg "haddock-html")
(goto-char (point-max))
(forward-line -1)
(beginning-of-line)
(when (looking-at "^haddock-html: \\([^ \n]+\\)$")
(match-string-no-properties 1))))
(defconst ghc-doc-local-format "file://%s/%s.html") (defconst ghc-doc-local-format "file://%s/%s.html")
(defconst ghc-doc-hackage-format (defconst ghc-doc-hackage-format
"http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html")
(ghc-defstruct pkg-ver pkg ver) (defun ghc-display-document (pkg-ver-path mod haskell-org &optional symbol)
(defun ghc-display-document (pkg-ver mod haskell-org &optional symbol)
(when (and pkg-ver mod)
(let* ((mod- (ghc-replace-character mod ?. ?-)) (let* ((mod- (ghc-replace-character mod ?. ?-))
(pkg (ghc-pkg-ver-get-pkg pkg-ver)) (pkg (ghc-pkg-ver-path-get-pkg pkg-ver-path))
(ver (ghc-pkg-ver-get-ver pkg-ver)) (ver (ghc-pkg-ver-path-get-ver pkg-ver-path))
(path (ghc-pkg-ver-path-get-path pkg-ver-path))
(pkg-with-ver (format "%s-%s" pkg ver)) (pkg-with-ver (format "%s-%s" pkg ver))
(path (ghc-resolve-document-path pkg-with-ver))
(local (format ghc-doc-local-format path mod-)) (local (format ghc-doc-local-format path mod-))
(remote (format ghc-doc-hackage-format pkg ver mod-)) (remote (format ghc-doc-hackage-format pkg ver mod-))
(file (format "%s/%s.html" path mod-)) (file (format "%s/%s.html" path mod-))
(url0 (if (or haskell-org (not (file-exists-p file))) remote local)) (url0 (if (or haskell-org (not (file-exists-p file))) remote local))
(url (if symbol (ghc-add-anchor url0 symbol) url0))) (url (if symbol (ghc-add-anchor url0 symbol) url0)))
;; Mac's "open" removes the anchor from "file://", sigh. ;; Mac's "open" removes the anchor from "file://", sigh.
(browse-url url)))) (browse-url url)))
(defun ghc-add-anchor (url symbol) (defun ghc-add-anchor (url symbol)
(let ((case-fold-search nil)) (let ((case-fold-search nil))