diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el index 9764557..2175889 100644 --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -8,17 +8,28 @@ (require 'ghc-func) (require 'ghc-comp) +(require 'ghc-info) ;;; Code: (defun ghc-browse-document (&optional haskell-org) (interactive "P") - (let* ((mod0 (ghc-extract-module)) - (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")))) + (let ((mod0 (ghc-extract-module)) + (expr (ghc-things-at-point))) + (cond + ((and (not mod0) expr) + (let* ((info (ghc-get-info expr)) + (mod (ghc-extact-module-from-info info)) + (pkg (ghc-resolve-package-name mod))) + (if (and pkg mod) + (ghc-display-document pkg mod haskell-org expr) + (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) (with-temp-buffer @@ -44,7 +55,7 @@ (ghc-defstruct pkg-ver pkg ver) -(defun ghc-display-document (pkg-ver mod haskell-org) +(defun ghc-display-document (pkg-ver mod haskell-org &optional symbol) (when (and pkg-ver mod) (let* ((mod- (ghc-replace-character mod ?. ?-)) (pkg (ghc-pkg-ver-get-pkg pkg-ver)) @@ -54,9 +65,32 @@ (local (format ghc-doc-local-format path mod-)) (remote (format ghc-doc-hackage-format pkg ver mod-)) (file (format "%s/%s.html" path mod-)) - (url (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))) + ;; Mac's "open" removes the anchor from "file://", sigh. (browse-url url)))) +(defun ghc-add-anchor (url symbol) + (let ((case-fold-search nil)) + (if (string-match "^[A-Z]" symbol) + (concat url "#t:" symbol) + (if (string-match "^[a-z]" symbol) + (concat url "#v:" symbol) + (concat url "#v:" (ghc-url-encode symbol)))))) + +(defun ghc-url-encode (symbol) + (let ((len (length symbol)) + (i 0) + acc) + (while (< i len) + (setq acc (cons (format "-%d-" (aref symbol i)) acc)) + (setq i (1+ i))) + (apply 'concat (nreverse acc)))) + +(defun ghc-extact-module-from-info (info) + (when (string-match "\`\\([^']+\\)'" info) + (match-string 1 info))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-input-map nil) diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el index 31aa108..389932f 100644 --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -78,7 +78,7 @@ (errs (ghc-flymake-err-list))) (ghc-display nil - (lambda (&rest ignore) + (lambda () (insert title "\n\n") (mapc (lambda (x) (insert x "\n")) errs)))))) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el index 5bac799..b409128 100644 --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -147,11 +147,10 @@ (defconst ghc-error-buffer-name "*GHC Info*") (defun ghc-display (fontify ins-func) - (let ((cdir default-directory) - (buf (get-buffer-create ghc-error-buffer-name))) + (let ((buf (get-buffer-create ghc-error-buffer-name))) (with-current-buffer buf (erase-buffer) - (funcall ins-func cdir) + (funcall ins-func) (ghc-replace-character-buffer ghc-null ghc-newline) (goto-char (point-min)) (if (not fontify) @@ -160,4 +159,19 @@ (turn-on-haskell-font-lock))) (display-buffer buf))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-run-ghc-mod (cmds) + (cond + ((executable-find ghc-module-command) + (let ((cdir default-directory)) + (with-temp-buffer + (cd cdir) + (apply 'call-process ghc-module-command nil t nil + (append (ghc-make-ghc-options) cmds)) + (buffer-substring (point-min) (1- (point-max)))))) + (t + (message "%s not found" ghc-module-command) + nil))) + (provide 'ghc-func) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index 8f2caab..cc421ac 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -12,12 +12,19 @@ (defun ghc-show-info (&optional ask) (interactive "P") - (let* ((modname (or (ghc-find-module-name) "Main")) - (expr0 (ghc-things-at-point)) + (let* ((expr0 (ghc-things-at-point)) (expr (if (or ask (not expr0)) (ghc-read-expression expr0) expr0)) + (info (ghc-get-info expr))) + (when info + (ghc-display + nil + (lambda () (insert info)))))) + +(defun ghc-get-info (expr) + (let* ((modname (or (ghc-find-module-name) "Main")) (file (buffer-file-name)) (cmds (list "info" file modname expr))) - (ghc-display-information cmds nil))) + (ghc-run-ghc-mod cmds))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -124,27 +131,12 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file))) - (ghc-display-information cmds t))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Display -;;; - -(defun ghc-display-information (cmds fontify) - (interactive) - (if (not (executable-find ghc-module-command)) - (message "%s not found" ghc-module-command) - (ghc-display - fontify - (lambda (cdir) - (insert - (with-temp-buffer - (cd cdir) - (apply 'call-process ghc-module-command nil t nil - (append (ghc-make-ghc-options) cmds)) - (buffer-substring (point-min) (1- (point-max))))))))) + (cmds (list "expand" file)) + (source (ghc-run-ghc-mod cmds))) + (when source + (ghc-display + 'fontify + (lambda () (insert source)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;