diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-doc.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-doc.el | 1861 |
1 files changed, 1861 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-doc.el b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-doc.el new file mode 100644 index 0000000000..5ac49b8f87 --- /dev/null +++ b/configs/shared/emacs/.emacs.d/elpa/haskell-mode-20180601.143/haskell-doc.el @@ -0,0 +1,1861 @@ +;;; haskell-doc.el --- show function types in echo area -*- coding: utf-8; lexical-binding: t -*- + +;; Copyright © 2004, 2005, 2006, 2007, 2009, 2016 Free Software Foundation, Inc. +;; Copyright © 1997 Hans-Wolfgang Loidl +;; 2016 Arthur Fayzrakhmanov + +;; Author: Hans-Wolfgang Loidl <hwloidl@dcs.glasgow.ac.uk> +;; Temporary Maintainer and Hacker: Graeme E Moss <gem@cs.york.ac.uk> +;; Keywords: extensions, minor mode, language mode, Haskell +;; Created: 1997-06-17 +;; URL: http://cvs.haskell.org/cgi-bin/cvsweb.cgi/fptools/CONTRIB/haskell-modes/emacs/haskell-doc.el?rev=HEAD + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This program shows the type of the Haskell function under the cursor in the +;; minibuffer. It acts as a kind of "Emacs background process", by regularly +;; checking the word under the cursor and matching it against a list of +;; prelude, library, local and global functions. + +;; This program was inspired by the `eldoc.el' package by Noah Friedman. + +;; Installation: + +;; Depending on the major mode you use for your Haskell programs add +;; one of the following to your .emacs: +;; +;; (add-hook 'haskell-mode-hook 'haskell-doc-mode) + +;; Customisation: + +;; You can control what exactly is shown by setting the following variables to +;; either t or nil: +;; `haskell-doc-show-global-types' (default: nil) +;; `haskell-doc-show-reserved' (default: t) +;; `haskell-doc-show-prelude' (default: t) +;; `haskell-doc-show-strategy' (default: t) +;; `haskell-doc-show-user-defined' (default: t) + +;; If you want to define your own strings for some identifiers define an +;; alist of (ID . STRING) and set `haskell-doc-show-user-defined' to t. +;; E.g: +;; +;; (setq haskell-doc-show-user-defined t) +;; (setq haskell-doc-user-defined-ids +;; (list +;; '("main" . "just another pathetic main function") +;; '("foo" . "a very dummy name") +;; '("bar" . "another dummy name"))) + +;; The following two variables are useful to make the type fit on one line: +;; If `haskell-doc-chop-off-context' is non-nil the context part of the type +;; of a local fct will be eliminated (default: t). +;; If `haskell-doc-chop-off-fctname' is non-nil the function name is not +;; shown together with the type (default: nil). + +;; Internals: + +;; `haskell-doc-mode' is implemented as a minor-mode. So, you can combine it +;; with any other mode. To enable it just type +;; M-x haskell-doc-mode + +;; These are the names of the functions that can be called directly by the +;; user (with keybindings in `haskell-mode'): +;; `haskell-doc-mode' ... toggle haskell-doc-mode; with prefix turn it on +;; unconditionally if the prefix is greater 0 otherwise +;; turn it off +;; Key: CTRL-c CTRL-o (CTRL-u CTRL-c CTRL-o) +;; `haskell-doc-ask-mouse-for-type' ... show the type of the id under the mouse +;; Key: C-S-M-mouse-3 +;; `haskell-doc-show-reserved' ... toggle echoing of reserved id's types +;; `haskell-doc-show-prelude' ... toggle echoing of prelude id's types +;; `haskell-doc-show-strategy' ... toggle echoing of strategy id's types +;; `haskell-doc-show-user-defined' ... toggle echoing of user def id's types +;; `haskell-doc-check-active' ... check whether haskell-doc is active; +;; Key: CTRL-c ESC-/ + +;; ToDo: + +;; - Fix byte-compile problems in `haskell-doc-prelude-types' for getArgs etc +;; - Write a parser for .hi files. Read library interfaces via this parser. +;; - Indicate kind of object with colours +;; - Handle multi-line types +;; - Encode i-am-fct info in the alist of ids and types. + +;; Bugs: + +;; - Some prelude fcts aren't displayed properly. This might be due to a +;; name clash of Haskell and Elisp functions (e.g. length) which +;; confuses Emacs when reading `haskell-doc-prelude-types' + +;;; Changelog: + +;; $Log: haskell-doc.el,v $ +;; Revision 1.31 2015/07/23 10:34:20 ankhers +;; (turn-on-haskell-doc-mode): marked obsolete +;; (turn-on-haskell-doc): marked obsolete +;; other packages have been moving away from (turn-on-haskell-*) +;; +;; Revision 1.30 2009/02/02 21:00:33 monnier +;; (haskell-doc-imported-list): Don't add current buffer +;; to the imported file list if it is not (yet?) visiting a file. +;; +;; Revision 1.29 2007-12-12 04:04:19 monnier +;; (haskell-doc-in-code-p): New function. +;; (haskell-doc-show-type): Use it. +;; +;; Revision 1.28 2007/08/30 03:10:08 monnier +;; Comment/docs fixes. +;; +;; Revision 1.27 2007/07/30 17:36:50 monnier +;; (displayed-month): Remove declaration since it's not used here. +;; +;; Revision 1.26 2007/02/10 06:28:55 monnier +;; (haskell-doc-get-current-word): Remove. +;; Change all refs to it, to use haskell-ident-at-point instead. +;; +;; Revision 1.25 2007/02/09 21:53:42 monnier +;; (haskell-doc-get-current-word): Correctly distinguish +;; variable identifiers and infix identifiers. +;; (haskell-doc-rescan-files): Avoid switch-to-buffer. +;; (haskell-doc-imported-list): Operate on current buffer. +;; (haskell-doc-make-global-fct-index): Adjust call. +;; +;; Revision 1.24 2006/11/20 20:18:24 monnier +;; (haskell-doc-mode-print-current-symbol-info): Fix thinko. +;; +;; Revision 1.23 2006/10/20 03:12:31 monnier +;; Drop post-command-idle-hook in favor of run-with-idle-timer. +;; (haskell-doc-timer, haskell-doc-buffers): New vars. +;; (haskell-doc-mode): Use them. +;; (haskell-doc-check-active): Update the check. +;; (haskell-doc-mode-print-current-symbol-info): Remove the interactive spec. +;; Don't sit-for unless it's really needed. +;; +;; Revision 1.22 2006/09/20 18:42:35 monnier +;; Doc fix. +;; +;; Revision 1.21 2005/11/21 21:48:52 monnier +;; * haskell-doc.el (haskell-doc-extract-types): Get labelled data working. +;; (haskell-doc-prelude-types): Update via auto-generation. +;; +;; * haskell-doc.el (haskell-doc-extract-types): Get it partly working. +;; (haskell-doc-fetch-lib-urls): Don't use a literal if we apply +;; `nreverse' on it later on. +;; (haskell-doc-prelude-types): Update some parts by auto-generation. +;; (haskell-doc-grab, haskell-doc-string-nub-ws): Simplify. +;; +;; * haskell-doc.el (haskell-doc-maintainer, haskell-doc-varlist) +;; (haskell-doc-submit-bug-report, haskell-doc-ftp-site) +;; (haskell-doc-visit-home): Remove. +;; (haskell-doc-reserved-ids, haskell-doc-fetch-lib-urls) +;; (haskell-doc-extract-and-insert-types): New funs. +;; (haskell-doc-reserved-ids): Fix type of `map'. +;; +;; Revision 1.20 2005/11/21 21:27:57 monnier +;; (haskell-doc-extract-types): Get labelled data working. +;; (haskell-doc-prelude-types): Update via auto-generation. +;; +;; Revision 1.19 2005/11/21 20:44:13 monnier +;; (haskell-doc-extract-types): Get it partly working. +;; (haskell-doc-fetch-lib-urls): Don't use a literal if we apply +;; `nreverse' on it later on. +;; (haskell-doc-prelude-types): Update some parts by auto-generation. +;; (haskell-doc-grab, haskell-doc-string-nub-ws): Simplify. +;; +;; Revision 1.18 2005/11/21 18:02:15 monnier +;; (haskell-doc-maintainer, haskell-doc-varlist) +;; (haskell-doc-submit-bug-report, haskell-doc-ftp-site) +;; (haskell-doc-visit-home): Remove. +;; (haskell-doc-reserved-ids, haskell-doc-fetch-lib-urls) +;; (haskell-doc-extract-and-insert-types): New funs. +;; (haskell-doc-reserved-ids): Fix type of `map'. +;; +;; Revision 1.17 2005/11/20 23:55:09 monnier +;; Add coding cookie. +;; +;; Revision 1.16 2005/11/07 01:28:16 monnier +;; (haskell-doc-xemacs-p, haskell-doc-emacs-p) +;; (haskell-doc-message): Remove. +;; (haskell-doc-is-id-char-at): Remove. +;; (haskell-doc-get-current-word): Rewrite. +;; +;; Revision 1.15 2005/11/04 17:11:12 monnier +;; Add arch-tag. +;; +;; Revision 1.14 2005/08/24 11:36:32 monnier +;; (haskell-doc-message): Paren typo. +;; +;; Revision 1.13 2005/08/23 19:23:27 monnier +;; (haskell-doc-show-type): Assume that the availability +;; of display-message won't change at runtime. +;; +;; Revision 1.12 2005/07/18 21:04:14 monnier +;; (haskell-doc-message): Remove. +;; (haskell-doc-show-type): inline it. Do nothing for if there's no doc to show. +;; +;; Revision 1.11 2004/12/10 17:33:18 monnier +;; (haskell-doc-minor-mode-string): Make it dynamic. +;; (haskell-doc-install-keymap): Remove conflicting C-c C-o binding. +;; (haskell-doc-mode): Make a nil arg turn the mode ON. +;; (turn-on-haskell-doc-mode): Make it an alias for haskell-doc-mode. +;; (haskell-doc-mode): Don't touch haskell-doc-minor-mode-string. +;; (haskell-doc-show-global-types): Don't touch +;; haskell-doc-minor-mode-string. Call haskell-doc-make-global-fct-index. +;; (haskell-doc-check-active): Fix message. +;; (define-key-after): Don't define. +;; (haskell-doc-install-keymap): Check existence of define-key-after. +;; +;; Revision 1.10 2004/11/25 23:03:23 monnier +;; (haskell-doc-sym-doc): Make even the last char bold. +;; +;; Revision 1.9 2004/11/24 22:14:36 monnier +;; (haskell-doc-install-keymap): Don't blindly assume there's a Hugs menu. +;; +;; Revision 1.8 2004/11/22 10:45:35 simonmar +;; Fix type of getLine +;; +;; Revision 1.7 2004/10/14 22:27:47 monnier +;; (turn-off-haskell-doc-mode, haskell-doc-current-info): Don't autoload. +;; +;; Revision 1.6 2004/10/13 22:45:22 monnier +;; (haskell-doc): New group. +;; (haskell-doc-show-reserved, haskell-doc-show-prelude) +;; (haskell-doc-show-strategy, haskell-doc-show-user-defined) +;; (haskell-doc-chop-off-context, haskell-doc-chop-off-fctname): +;; Make them custom vars. +;; (haskell-doc-keymap): Declare and fill it right there. +;; (haskell-doc-mode): Simplify. +;; (haskell-doc-toggle-var): Make it into what it was supposed to be. +;; (haskell-doc-mode-print-current-symbol-info): Simplify. +;; (haskell-doc-current-info): New autoloaded function. +;; (haskell-doc-sym-doc): New fun extracted from haskell-doc-show-type. +;; (haskell-doc-show-type): Use it. +;; (haskell-doc-wrapped-type-p): Remove unused var `lim'. +;; (haskell-doc-forward-sexp-safe, haskell-doc-current-symbol): Remove. Unused. +;; (haskell-doc-visit-home): Don't require ange-ftp, it's autoloaded. +;; (haskell-doc-install-keymap): Simplify. +;; +;; Revision 1.5 2003/01/09 11:56:26 simonmar +;; Patches from Ville Skyttä <scop@xemacs.org>, the XEmacs maintainer of +;; the haskell-mode: +;; +;; - Make the auto-mode-alist modifications autoload-only. +;; +;; Revision 1.4 2002/10/14 09:55:03 simonmar +;; Patch to update the Prelude/libraries function names and to remove +;; support for older versions of Haskell. +;; +;; Submitted by: Anders Lau Olsen <alauo@mip.sdu.dk> +;; +;; Revision 1.3 2002/04/30 09:34:37 rrt +;; Remove supporting Haskell 1.4 and 1.2 from the ToDo list. It's Far Too Late. +;; +;; Add (require 'imenu). Thanks to N. Y. Kwok. +;; +;; Revision 1.2 2002/04/23 14:45:10 simonmar +;; Tweaks to the doc strings and support for customization, from +;; Ville Skyttä <scop@xemacs.org>. +;; +;; Revision 1.1 2001/07/19 16:17:36 rrt +;; Add the current version of the Moss/Thorn/Marlow Emacs mode, along with its +;; web pages and sample files. This is now the preferred mode, and the +;; haskell.org pages are being changed to reflect that. Also includes the new +;; GHCi mode from Chris Webb. +;; +;; Revision 1.6 1998/12/10 16:27:25 hwloidl +;; Minor changes ("Doc" as modeline string, mouse-3 moved to C-S-M-mouse-3) +;; +;; Revision 1.5 1998/09/24 14:25:46 gem +;; Fixed minor compatibility bugs with Haskell mode of Moss&Thorn. +;; Disabled M-/ binding. +;; +;; Revision 1.4 1997/11/12 23:51:19 hwloidl +;; Fixed start-up problem under emacs-19.34. +;; Added support for wrapped (multi-line) types and 2 vars to control the +;; behaviour with long fct types +;; +;; Revision 1.3 1997/11/03 00:48:03 hwloidl +;; Major revision for first release. +;; Added alists for showing prelude fcts, haskell syntax, and strategies +;; Added mouse interface to show type under mouse +;; Fixed bug which causes demon to fall over +;; Works now with hugs-mode and haskell-mode under emacs 19.34,20 and xemacs 19.15 +;; + +;;; Code: + +(require 'haskell-mode) +(require 'haskell-process) +(require 'haskell) +(require 'haskell-utils) +(require 'inf-haskell) +(require 'imenu) +(require 'eldoc) + +;;;###autoload +(defgroup haskell-doc nil + "Show Haskell function types in echo area." + :group 'haskell + :prefix "haskell-doc-") + + +(defvar-local haskell-doc-mode nil + "*If non-nil, show the type of the function near point or a related comment. + +If the identifier near point is a Haskell keyword and the variable +`haskell-doc-show-reserved' is non-nil show a one line summary +of the syntax. + +If the identifier near point is a Prelude or one of the standard library +functions and `haskell-doc-show-prelude' is non-nil show its type. + +If the identifier near point is local \(i.e. defined in this module\) check +the `imenu' list of functions for the type. This obviously requires that +your language mode uses `imenu'. + +If the identifier near point is global \(i.e. defined in an imported module\) +and the variable `haskell-doc-show-global-types' is non-nil show the type of its +function. + +If the identifier near point is a standard strategy or a function, type related +related to strategies and `haskell-doc-show-strategy' is non-nil show the type +of the function. Strategies are special to the parallel execution of Haskell. +If you're not interested in that just turn it off. + +If the identifier near point is a user defined function that occurs as key +in the alist `haskell-doc-user-defined-ids' and the variable +`haskell-doc-show-user-defined' is non-nil show the type of the function. + +This variable is buffer-local.") + +(defvar haskell-doc-mode-hook nil + "Hook invoked when entering `haskell-doc-mode'.") + +(defvar-local haskell-doc-index nil + "Variable holding an alist matching file names to fct-type alists. +The function `haskell-doc-make-global-fct-index' rebuilds this variables +\(similar to an `imenu' rescan\). +This variable is buffer-local.") + +(defcustom haskell-doc-show-global-types nil + "If non-nil, search for the types of global functions by loading the files. +This variable is buffer-local." + :group 'haskell-doc + :type 'boolean) +(make-variable-buffer-local 'haskell-doc-show-global-types) + +(defcustom haskell-doc-show-reserved t + "If non-nil, show a documentation string for reserved ids. +This variable is buffer-local." + :group 'haskell-doc + :type 'boolean) +(make-variable-buffer-local 'haskell-doc-show-reserved) + +(defcustom haskell-doc-show-prelude t + "If non-nil, show a documentation string for prelude functions. +This variable is buffer-local." + :group 'haskell-doc + :type 'boolean) +(make-variable-buffer-local 'haskell-doc-show-prelude) + +(defcustom haskell-doc-show-strategy t + "If non-nil, show a documentation string for strategies. +This variable is buffer-local." + :group 'haskell-doc + :type 'boolean) +(make-variable-buffer-local 'haskell-doc-show-strategy) + +(defcustom haskell-doc-show-user-defined t + "If non-nil, show a documentation string for user defined ids. +This variable is buffer-local." + :group 'haskell-doc + :type 'boolean) +(make-variable-buffer-local 'haskell-doc-show-user-defined) + +(defcustom haskell-doc-chop-off-context t + "If non-nil eliminate the context part in a Haskell type." + :group 'haskell-doc + :type 'boolean) + +(defcustom haskell-doc-chop-off-fctname nil + "If non-nil omit the function name and show only the type." + :group 'haskell-doc + :type 'boolean) + +(defcustom haskell-doc-use-inf-haskell nil + "If non-nil use inf-haskell.el to get type and kind information." + :group 'haskell-doc + :type 'boolean) + +(defvar haskell-doc-search-distance 40 ; distance in characters + "*How far to search when looking for the type declaration of fct under cursor.") + + +(defvar haskell-doc-idle-delay 0.50 + "*Number of seconds of idle time to wait before printing. +If user input arrives before this interval of time has elapsed after the +last input, no documentation will be printed. + +If this variable is set to 0, no idle time is required.") + +(defvar haskell-doc-argument-case 'identity ; 'upcase + "Case in which to display argument names of functions, as a symbol. +This has two preferred values: `upcase' or `downcase'. +Actually, any name of a function which takes a string as an argument and +returns another string is acceptable.") + +(defvar haskell-doc-mode-message-commands nil + "*Obarray of command names where it is appropriate to print in the echo area. + +This is not done for all commands since some print their own +messages in the echo area, and these functions would instantly overwrite +them. But `self-insert-command' as well as most motion commands are good +candidates. + +It is probably best to manipulate this data structure with the commands +`haskell-doc-add-command' and `haskell-doc-remove-command'.") + +;;(cond ((null haskell-doc-mode-message-commands) +;; ;; If you increase the number of buckets, keep it a prime number. +;; (setq haskell-doc-mode-message-commands (make-vector 31 0)) +;; (let ((list '("self-insert-command" +;; "next-" "previous-" +;; "forward-" "backward-" +;; "beginning-of-" "end-of-" +;; "goto-" +;; "recenter" +;; "scroll-")) +;; (syms nil)) +;; (while list +;; (setq syms (all-completions (car list) obarray 'fboundp)) +;; (setq list (cdr list)) +;; (while syms +;; (set (intern (car syms) haskell-doc-mode-message-commands) t) +;; (setq syms (cdr syms))))))) + +;; Bookkeeping; the car contains the last symbol read from the buffer. +;; The cdr contains the string last displayed in the echo area, so it can +;; be printed again if necessary without reconsing. +(defvar haskell-doc-last-data '(nil . nil)) + +(defvar haskell-doc-minor-mode-string + '(haskell-doc-show-global-types " DOC" " Doc") + "*String to display in mode line when Haskell-Doc Mode is enabled.") + + +(defvar haskell-doc-reserved-ids + '(("case" . "case exp of { alts [;] }") + ("class" . "class [context =>] simpleclass [where { cbody [;] }]") + ("data" . "data [context =>] simpletype = constrs [deriving]") + ("default" . "default (type1 , ... , typen)") + ("deriving" . "deriving (dclass | (dclass1, ... , dclassn))") ; used with data or newtype + ("do" . "do { stmts [;] } stmts -> exp [; stmts] | pat <- exp ; stmts | let decllist ; stmts") + ("else" . "if exp then exp else exp") + ("if" . "if exp then exp else exp") + ("import" . "import [qualified] modid [as modid] [impspec]") + ("in" . "let decllist in exp") + ("infix" . "infix [digit] ops") + ("infixl" . "infixl [digit] ops") + ("infixr" . "infixr [digit] ops") + ("instance" . "instance [context =>] qtycls inst [where { valdefs [;] }]") + ("let" . "let { decl; ...; decl [;] } in exp") + ("module" . "module modid [exports] where body") + ("newtype" . "newtype [context =>] simpletype = con atype [deriving]") + ("of" . "case exp of { alts [;] }") + ("then" . "if exp then exp else exp") + ("type" . "type simpletype = type") + ("where" . "exp where { decl; ...; decl [;] }") ; check that ; see also class, instance, module + ("as" . "import [qualified] modid [as modid] [impspec]") + ("qualified" . "import [qualified] modid [as modid] [impspec]") + ("hiding" . "hiding ( import1 , ... , importn [ , ] )") + ("family" . "(type family type [kind] [= type_fam_equations]) | (data family type [kind])")) + "An alist of reserved identifiers. +Each element is of the form (ID . DOC) where both ID and DOC are strings. +DOC should be a concise single-line string describing the construct in which +the keyword is used.") + + +(defun haskell-doc-extract-types (url) + (with-temp-buffer + (insert-file-contents url) + (goto-char (point-min)) + (while (search-forward " " nil t) (replace-match " " t t)) + + ;; First, focus on the actual code, removing the surrounding HTML text. + (goto-char (point-min)) + (let ((last (point-min)) + (modules nil)) + (while (re-search-forward "^module +\\([[:alnum:]]+\\)" nil t) + (let ((module (match-string 1))) + (if (member module modules) + ;; The library nodes of the HTML doc contain modules twice: + ;; once at the top, with only type declarations, and once at + ;; the bottom with an actual sample implementation which may + ;; include declaration of non-exported values. + ;; We're now at this second occurrence is the implementation + ;; which should thus be ignored. + nil + (push module modules) + (delete-region last (point)) + (search-forward "</tt>") + ;; Some of the blocks of code are split. + (while (looking-at "\\(<[^<>]+>[ \t\n]*\\)*<tt>") + (goto-char (match-end 0)) + (search-forward "</tt>")) + (setq last (point))))) + (delete-region last (point-max)) + + ;; Then process the HTML encoding to get back to pure ASCII. + (goto-char (point-min)) + (while (search-forward "<br>" nil t) (replace-match "\n" t t)) + ;; (goto-char (point-min)) + ;; (while (re-search-forward "<[^<>]+>" nil t) (replace-match "" t t)) + (goto-char (point-min)) + (while (search-forward ">" nil t) (replace-match ">" t t)) + (goto-char (point-min)) + (while (search-forward "<" nil t) (replace-match "<" t t)) + (goto-char (point-min)) + (while (search-forward "&" nil t) (replace-match "&" t t)) + (goto-char (point-min)) + (if (re-search-forward "&[a-z]+;" nil t) + (error "Unexpected charref %s" (match-string 0))) + ;; Remove TABS. + (goto-char (point-min)) + (while (search-forward "\t" nil t) (replace-match " " t t)) + + ;; Finally, extract the actual data. + (goto-char (point-min)) + (let* ((elems nil) + (space-re "[ \t\n]*\\(?:--.*\n[ \t\n]*\\)*") + (comma-re (concat " *," space-re)) + ;; A list of identifiers. We have to be careful to weed out + ;; entries like "ratPrec = 7 :: Int". Also ignore entries + ;; which start with a < since they're actually in the HTML text + ;; part. And the list may be spread over several lines, cut + ;; after a comma. + (idlist-re + (concat "\\([^< \t\n][^ \t\n]*" + "\\(?:" comma-re "[^ \t\n]+\\)*\\)")) + ;; A type. A few types are spread over 2 lines, + ;; cut after the "=>", so we have to handle these as well. + (type-re "\\(.*[^\n>]\\(?:>[ \t\n]+.*[^\n>]\\)*\\) *$") + ;; A decl of a list of values, possibly indented. + (val-decl-re + (concat "^\\( +\\)?" idlist-re "[ \t\n]*::[ \t\n]*" type-re)) + (re (concat + ;; 3 possibilities: a class decl, a data decl, or val decl. + ;; First, let's match a class decl. + "^class \\(?:.*=>\\)? *\\(.*[^ \t\n]\\)[ \t\n]*where" + + ;; Or a value decl: + "\\|" val-decl-re + + "\\|" ;; Or a data decl. We only handle single-arm + ;; datatypes with labels. + "^data +\\([[:alnum:]][[:alnum:] ]*[[:alnum:]]\\)" + " *=.*{\\([^}]+\\)}" + )) + (re-class (concat "^[^ \t\n]\\|" re)) + curclass) + (while (re-search-forward (if curclass re-class re) nil t) + (cond + ;; A class decl. + ((match-end 1) (setq curclass (match-string 1))) + ;; A value decl. + ((match-end 4) + (let ((type (match-string 4)) + (vars (match-string 3)) + (indented (match-end 2))) + (if (string-match "[ \t\n][ \t\n]+" type) + (setq type (replace-match " " t t type))) + (if (string-match " *\\(--.*\\)?\\'" type) + (setq type (substring type 0 (match-beginning 0)))) + (if indented + (if curclass + (if (string-match "\\`\\(.*[^ \t\n]\\) *=> *" type) + (let ((classes (match-string 1 type))) + (setq type (substring type (match-end 0))) + (if (string-match "\\`(.*)\\'" classes) + (setq classes (substring classes 1 -1))) + (setq type (concat "(" curclass ", " classes + ") => " type))) + (setq type (concat curclass " => " type))) + ;; It's actually not an error: just a type annotation on + ;; some local variable. + ;; (error "Indentation outside a class in %s: %s" + ;; module vars) + nil) + (setq curclass nil)) + (dolist (var (split-string vars comma-re t)) + (if (string-match "(.*)" var) (setq var (substring var 1 -1))) + (push (cons var type) elems)))) + ;; A datatype decl. + ((match-end 5) + (setq curclass nil) + (let ((name (match-string 5))) + (save-excursion + (save-restriction + (narrow-to-region (match-beginning 6) (match-end 6)) + (goto-char (point-min)) + (while (re-search-forward val-decl-re nil t) + (let ((vars (match-string 2)) + (type (match-string 3))) + (if (string-match "[ \t\n][ \t\n]+" type) + (setq type (replace-match " " t t type))) + (if (string-match " *\\(--.*\\)?\\'" type) + (setq type (substring type 0 (match-beginning 0)))) + (if (string-match ",\\'" type) + (setq type (substring type 0 -1))) + (setq type (concat name " -> " type)) + (dolist (var (split-string vars comma-re t)) + (if (string-match "(.*)" var) + (setq var (substring var 1 -1))) + (push (cons var type) elems)))))))) + + ;; The end of a class declaration. + (t (setq curclass nil) (beginning-of-line)))) + (cons (car (last modules)) elems))))) + +(defun haskell-doc-fetch-lib-urls (base-url) + (with-temp-buffer + (insert-file-contents base-url) + (goto-char (point-min)) + (search-forward "Part II: Libraries") + (delete-region (point-min) (point)) + (search-forward "</table>") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (let ((libs (list "standard-prelude.html"))) + (while (re-search-forward "<a href=\"\\([^\"]+\\)\">" nil t) + (push (match-string 1) libs)) + (mapcar (lambda (s) (expand-file-name s (file-name-directory base-url))) + (nreverse libs))))) + +(defun haskell-doc-extract-and-insert-types (url) + "Fetch the types from the online doc and insert them at point. +URL is the URL of the online doc." + (interactive (if current-prefix-arg + (read-file-name "URL: ") + (list "http://www.haskell.org/onlinereport/"))) + (let ((urls (haskell-doc-fetch-lib-urls url))) + (dolist (url urls) + (let ((data (haskell-doc-extract-types url))) + (insert ";; " (pop data)) (indent-according-to-mode) (newline) + (dolist (elem (sort data (lambda (x y) (string-lessp (car x) (car y))))) + (prin1 elem (current-buffer)) + (indent-according-to-mode) (newline)))))) + +(defvar haskell-doc-prelude-types + ;; This list was auto generated by `haskell-doc-extract-and-insert-types'. + '( + ;; Prelude + ("!!" . "[a] -> Int -> a") + ("$" . "(a -> b) -> a -> b") + ("$!" . "(a -> b) -> a -> b") + ("&&" . "Bool -> Bool -> Bool") + ("*" . "Num a => a -> a -> a") + ("**" . "Floating a => a -> a -> a") + ("+" . "Num a => a -> a -> a") + ("++" . "[a] -> [a] -> [a]") + ("-" . "Num a => a -> a -> a") + ("." . "(b -> c) -> (a -> b) -> a -> c") + ("/" . "Fractional a => a -> a -> a") + ("/=" . "Eq a => a -> a -> Bool") + ("<" . "Ord a => a -> a -> Bool") + ("<=" . "Ord a => a -> a -> Bool") + ("=<<" . "Monad m => (a -> m b) -> m a -> m b") + ("==" . "Eq a => a -> a -> Bool") + (">" . "Ord a => a -> a -> Bool") + (">=" . "Ord a => a -> a -> Bool") + (">>" . "Monad m => m a -> m b -> m b") + (">>=" . "Monad m => m a -> (a -> m b) -> m b") + ("^" . "(Num a, Integral b) => a -> b -> a") + ("^^" . "(Fractional a, Integral b) => a -> b -> a") + ("abs" . "Num a => a -> a") + ("acos" . "Floating a => a -> a") + ("acosh" . "Floating a => a -> a") + ("all" . "(a -> Bool) -> [a] -> Bool") + ("and" . "[Bool] -> Bool") + ("any" . "(a -> Bool) -> [a] -> Bool") + ("appendFile" . "FilePath -> String -> IO ()") + ("asTypeOf" . "a -> a -> a") + ("asin" . "Floating a => a -> a") + ("asinh" . "Floating a => a -> a") + ("atan" . "Floating a => a -> a") + ("atan2" . "RealFloat a => a -> a -> a") + ("atanh" . "Floating a => a -> a") + ("break" . "(a -> Bool) -> [a] -> ([a],[a])") + ("catch" . "IO a -> (IOError -> IO a) -> IO a") + ("ceiling" . "(RealFrac a, Integral b) => a -> b") + ("compare" . "Ord a => a -> a -> Ordering") + ("concat" . "[[a]] -> [a]") + ("concatMap" . "(a -> [b]) -> [a] -> [b]") + ("const" . "a -> b -> a") + ("cos" . "Floating a => a -> a") + ("cosh" . "Floating a => a -> a") + ("curry" . "((a, b) -> c) -> a -> b -> c") + ("cycle" . "[a] -> [a]") + ("decodeFloat" . "RealFloat a => a -> (Integer,Int)") + ("div" . "Integral a => a -> a -> a") + ("divMod" . "Integral a => a -> a -> (a,a)") + ("drop" . "Int -> [a] -> [a]") + ("dropWhile" . "(a -> Bool) -> [a] -> [a]") + ("either" . "(a -> c) -> (b -> c) -> Either a b -> c") + ("elem" . "(Eq a) => a -> [a] -> Bool") + ("encodeFloat" . "RealFloat a => Integer -> Int -> a") + ("enumFrom" . "Enum a => a -> [a]") + ("enumFromThen" . "Enum a => a -> a -> [a]") + ("enumFromThenTo" . "Enum a => a -> a -> a -> [a]") + ("enumFromTo" . "Enum a => a -> a -> [a]") + ("error" . "String -> a") + ("even" . "(Integral a) => a -> Bool") + ("exp" . "Floating a => a -> a") + ("exponent" . "RealFloat a => a -> Int") + ("fail" . "Monad m => String -> m a") + ("filter" . "(a -> Bool) -> [a] -> [a]") + ("flip" . "(a -> b -> c) -> b -> a -> c") + ("floatDigits" . "RealFloat a => a -> Int") + ("floatRadix" . "RealFloat a => a -> Integer") + ("floatRange" . "RealFloat a => a -> (Int,Int)") + ("floor" . "(RealFrac a, Integral b) => a -> b") + ("fmap" . "Functor f => (a -> b) -> f a -> f b") + ("foldl" . "(a -> b -> a) -> a -> [b] -> a") + ("foldl1" . "(a -> a -> a) -> [a] -> a") + ("foldr" . "(a -> b -> b) -> b -> [a] -> b") + ("foldr1" . "(a -> a -> a) -> [a] -> a") + ("fromEnum" . "Enum a => a -> Int") + ("fromInteger" . "Num a => Integer -> a") + ("fromIntegral" . "(Integral a, Num b) => a -> b") + ("fromRational" . "Fractional a => Rational -> a") + ("fst" . "(a,b) -> a") + ("gcd" . "(Integral a) => a -> a -> a") + ("getChar" . "IO Char") + ("getContents" . "IO String") + ("getLine" . "IO String") + ("head" . "[a] -> a") + ("id" . "a -> a") + ("init" . "[a] -> [a]") + ("interact" . "(String -> String) -> IO ()") + ("ioError" . "IOError -> IO a") + ("isDenormalized" . "RealFloat a => a -> Bool") + ("isIEEE" . "RealFloat a => a -> Bool") + ("isInfinite" . "RealFloat a => a -> Bool") + ("isNaN" . "RealFloat a => a -> Bool") + ("isNegativeZero" . "RealFloat a => a -> Bool") + ("iterate" . "(a -> a) -> a -> [a]") + ("last" . "[a] -> a") + ("lcm" . "(Integral a) => a -> a -> a") + ("length" . "[a] -> Int") + ("lex" . "ReadS String") + ("lines" . "String -> [String]") + ("log" . "Floating a => a -> a") + ("logBase" . "Floating a => a -> a -> a") + ("lookup" . "(Eq a) => a -> [(a,b)] -> Maybe b") + ("map" . "(a -> b) -> [a] -> [b]") + ("mapM" . "Monad m => (a -> m b) -> [a] -> m [b]") + ("mapM_" . "Monad m => (a -> m b) -> [a] -> m ()") + ("max" . "Ord a => a -> a -> a") + ("maxBound" . "Bounded a => a") + ("maximum" . "(Ord a) => [a] -> a") + ("maybe" . "b -> (a -> b) -> Maybe a -> b") + ("min" . "Ord a => a -> a -> a") + ("minBound" . "Bounded a => a") + ("minimum" . "(Ord a) => [a] -> a") + ("mod" . "Integral a => a -> a -> a") + ("negate" . "Num a => a -> a") + ("not" . "Bool -> Bool") + ("notElem" . "(Eq a) => a -> [a] -> Bool") + ("null" . "[a] -> Bool") + ("numericEnumFrom" . "(Fractional a) => a -> [a]") + ("numericEnumFromThen" . "(Fractional a) => a -> a -> [a]") + ("numericEnumFromThenTo" . "(Fractional a, Ord a) => a -> a -> a -> [a]") + ("numericEnumFromTo" . "(Fractional a, Ord a) => a -> a -> [a]") + ("odd" . "(Integral a) => a -> Bool") + ("or" . "[Bool] -> Bool") + ("otherwise" . "Bool") + ("pi" . "Floating a => a") + ("pred" . "Enum a => a -> a") + ("print" . "Show a => a -> IO ()") + ("product" . "(Num a) => [a] -> a") + ("properFraction" . "(RealFrac a, Integral b) => a -> (b,a)") + ("putChar" . "Char -> IO ()") + ("putStr" . "String -> IO ()") + ("putStrLn" . "String -> IO ()") + ("quot" . "Integral a => a -> a -> a") + ("quotRem" . "Integral a => a -> a -> (a,a)") + ("read" . "(Read a) => String -> a") + ("readFile" . "FilePath -> IO String") + ("readIO" . "Read a => String -> IO a") + ("readList" . "Read a => ReadS [a]") + ("readLn" . "Read a => IO a") + ("readParen" . "Bool -> ReadS a -> ReadS a") + ("reads" . "(Read a) => ReadS a") + ("readsPrec" . "Read a => Int -> ReadS a") + ("realToFrac" . "(Real a, Fractional b) => a -> b") + ("recip" . "Fractional a => a -> a") + ("rem" . "Integral a => a -> a -> a") + ("repeat" . "a -> [a]") + ("replicate" . "Int -> a -> [a]") + ("return" . "Monad m => a -> m a") + ("reverse" . "[a] -> [a]") + ("round" . "(RealFrac a, Integral b) => a -> b") + ("scaleFloat" . "RealFloat a => Int -> a -> a") + ("scanl" . "(a -> b -> a) -> a -> [b] -> [a]") + ("scanl1" . "(a -> a -> a) -> [a] -> [a]") + ("scanr" . "(a -> b -> b) -> b -> [a] -> [b]") + ("scanr1" . "(a -> a -> a) -> [a] -> [a]") + ("seq" . "a -> b -> b") + ("sequence" . "Monad m => [m a] -> m [a]") + ("sequence_" . "Monad m => [m a] -> m ()") + ("show" . "Show a => a -> String") + ("showChar" . "Char -> ShowS") + ("showList" . "Show a => [a] -> ShowS") + ("showParen" . "Bool -> ShowS -> ShowS") + ("showString" . "String -> ShowS") + ("shows" . "(Show a) => a -> ShowS") + ("showsPrec" . "Show a => Int -> a -> ShowS") + ("significand" . "RealFloat a => a -> a") + ("signum" . "Num a => a -> a") + ("sin" . "Floating a => a -> a") + ("sinh" . "Floating a => a -> a") + ("snd" . "(a,b) -> b") + ("span" . "(a -> Bool) -> [a] -> ([a],[a])") + ("splitAt" . "Int -> [a] -> ([a],[a])") + ("sqrt" . "Floating a => a -> a") + ("subtract" . "(Num a) => a -> a -> a") + ("succ" . "Enum a => a -> a") + ("sum" . "(Num a) => [a] -> a") + ("tail" . "[a] -> [a]") + ("take" . "Int -> [a] -> [a]") + ("takeWhile" . "(a -> Bool) -> [a] -> [a]") + ("tan" . "Floating a => a -> a") + ("tanh" . "Floating a => a -> a") + ("toEnum" . "Enum a => Int -> a") + ("toInteger" . "Integral a => a -> Integer") + ("toRational" . "Real a => a -> Rational") + ("truncate" . "(RealFrac a, Integral b) => a -> b") + ("uncurry" . "(a -> b -> c) -> ((a, b) -> c)") + ("undefined" . "a") + ("unlines" . "[String] -> String") + ("until" . "(a -> Bool) -> (a -> a) -> a -> a") + ("unwords" . "[String] -> String") + ("unzip" . "[(a,b)] -> ([a],[b])") + ("unzip3" . "[(a,b,c)] -> ([a],[b],[c])") + ("userError" . "String -> IOError") + ("words" . "String -> [String]") + ("writeFile" . "FilePath -> String -> IO ()") + ("zip" . "[a] -> [b] -> [(a,b)]") + ("zip3" . "[a] -> [b] -> [c] -> [(a,b,c)]") + ("zipWith" . "(a->b->c) -> [a]->[b]->[c]") + ("zipWith3" . "(a->b->c->d) -> [a]->[b]->[c]->[d]") + ("||" . "Bool -> Bool -> Bool") + ;; Ratio + ("%" . "(Integral a) => a -> a -> Ratio a") + ("approxRational" . "(RealFrac a) => a -> a -> Rational") + ("denominator" . "(Integral a) => Ratio a -> a") + ("numerator" . "(Integral a) => Ratio a -> a") + ;; Complex + ("cis" . "(RealFloat a) => a -> Complex a") + ("conjugate" . "(RealFloat a) => Complex a -> Complex a") + ("imagPart" . "(RealFloat a) => Complex a -> a") + ("magnitude" . "(RealFloat a) => Complex a -> a") + ("mkPolar" . "(RealFloat a) => a -> a -> Complex a") + ("phase" . "(RealFloat a) => Complex a -> a") + ("polar" . "(RealFloat a) => Complex a -> (a,a)") + ("realPart" . "(RealFloat a) => Complex a -> a") + ;; Numeric + ("floatToDigits" . "(RealFloat a) => Integer -> a -> ([Int], Int)") + ("fromRat" . "(RealFloat a) => Rational -> a") + ("lexDigits" . "ReadS String") + ("readDec" . "(Integral a) => ReadS a") + ("readFloat" . "(RealFrac a) => ReadS a") + ("readHex" . "(Integral a) => ReadS a") + ("readInt" . "(Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a") + ("readOct" . "(Integral a) => ReadS a") + ("readSigned" . "(Real a) => ReadS a -> ReadS a") + ("showEFloat" . "(RealFloat a) => Maybe Int -> a -> ShowS") + ("showFFloat" . "(RealFloat a) => Maybe Int -> a -> ShowS") + ("showFloat" . "(RealFloat a) => a -> ShowS") + ("showGFloat" . "(RealFloat a) => Maybe Int -> a -> ShowS") + ("showHex" . "Integral a => a -> ShowS") + ("showInt" . "Integral a => a -> ShowS") + ("showIntAtBase" . "Integral a => a -> (Int -> Char) -> a -> ShowS") + ("showOct" . "Integral a => a -> ShowS") + ("showSigned" . "(Real a) => (a -> ShowS) -> Int -> a -> ShowS") + ;; Ix + ("inRange" . "Ix a => (a,a) -> a -> Bool") + ("index" . "Ix a => (a,a) -> a -> Int") + ("range" . "Ix a => (a,a) -> [a]") + ("rangeSize" . "Ix a => (a,a) -> Int") + ;; Array + ("!" . "(Ix a) => Array a b -> a -> b") + ("//" . "(Ix a) => Array a b -> [(a,b)] -> Array a b") + ("accum" . "(Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]") + ("accumArray" . "(Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]") + ("array" . "(Ix a) => (a,a) -> [(a,b)] -> Array a b") + ("assocs" . "(Ix a) => Array a b -> [(a,b)]") + ("bounds" . "(Ix a) => Array a b -> (a,a)") + ("elems" . "(Ix a) => Array a b -> [b]") + ("indices" . "(Ix a) => Array a b -> [a]") + ("ixmap" . "(Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c") + ("listArray" . "(Ix a) => (a,a) -> [b] -> Array a b") + ;; List + ("\\\\" . "Eq a => [a] -> [a] -> [a]") + ("delete" . "Eq a => a -> [a] -> [a]") + ("deleteBy" . "(a -> a -> Bool) -> a -> [a] -> [a]") + ("deleteFirstsBy" . "(a -> a -> Bool) -> [a] -> [a] -> [a]") + ("elemIndex" . "Eq a => a -> [a] -> Maybe Int") + ("elemIndices" . "Eq a => a -> [a] -> [Int]") + ("find" . "(a -> Bool) -> [a] -> Maybe a") + ("findIndex" . "(a -> Bool) -> [a] -> Maybe Int") + ("findIndices" . "(a -> Bool) -> [a] -> [Int]") + ("genericDrop" . "Integral a => a -> [b] -> [b]") + ("genericIndex" . "Integral a => [b] -> a -> b") + ("genericLength" . "Integral a => [b] -> a") + ("genericReplicate" . "Integral a => a -> b -> [b]") + ("genericSplitAt" . "Integral a => a -> [b] -> ([b],[b])") + ("genericTake" . "Integral a => a -> [b] -> [b]") + ("group" . "Eq a => [a] -> [[a]]") + ("groupBy" . "(a -> a -> Bool) -> [a] -> [[a]]") + ("inits" . "[a] -> [[a]]") + ("insert" . "Ord a => a -> [a] -> [a]") + ("insertBy" . "(a -> a -> Ordering) -> a -> [a] -> [a]") + ("intersect" . "Eq a => [a] -> [a] -> [a]") + ("intersectBy" . "(a -> a -> Bool) -> [a] -> [a] -> [a]") + ("intersperse" . "a -> [a] -> [a]") + ("isPrefixOf" . "Eq a => [a] -> [a] -> Bool") + ("isSuffixOf" . "Eq a => [a] -> [a] -> Bool") + ("mapAccumL" . "(a -> b -> (a, c)) -> a -> [b] -> (a, [c])") + ("mapAccumR" . "(a -> b -> (a, c)) -> a -> [b] -> (a, [c])") + ("maximumBy" . "(a -> a -> Ordering) -> [a] -> a") + ("minimumBy" . "(a -> a -> Ordering) -> [a] -> a") + ("nub" . "Eq a => [a] -> [a]") + ("nubBy" . "(a -> a -> Bool) -> [a] -> [a]") + ("partition" . "(a -> Bool) -> [a] -> ([a],[a])") + ("sort" . "Ord a => [a] -> [a]") + ("sortBy" . "(a -> a -> Ordering) -> [a] -> [a]") + ("tails" . "[a] -> [[a]]") + ("transpose" . "[[a]] -> [[a]]") + ("unfoldr" . "(b -> Maybe (a,b)) -> b -> [a]") + ("union" . "Eq a => [a] -> [a] -> [a]") + ("unionBy" . "(a -> a -> Bool) -> [a] -> [a] -> [a]") + ("unzip4" . "[(a,b,c,d)] -> ([a],[b],[c],[d])") + ("unzip5" . "[(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])") + ("unzip6" . "[(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])") + ("unzip7" . "[(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])") + ("zip4" . "[a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]") + ("zip5" . "[a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]") + ("zip6" . "[a] -> [b] -> [c] -> [d] -> [e] -> [f]") + ("zip7" . "[a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]") + ("zipWith4" . "(a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]") + ("zipWith5" . "(a->b->c->d->e->f) ->") + ("zipWith6" . "(a->b->c->d->e->f->g) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]") + ("zipWith7" . "(a->b->c->d->e->f->g->h) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]") + ;; Maybe + ("catMaybes" . "[Maybe a] -> [a]") + ("fromJust" . "Maybe a -> a") + ("fromMaybe" . "a -> Maybe a -> a") + ("isJust" . "Maybe a -> Bool") + ("isNothing" . "Maybe a -> Bool") + ("listToMaybe" . "[a] -> Maybe a") + ("mapMaybe" . "(a -> Maybe b) -> [a] -> [b]") + ("maybeToList" . "Maybe a -> [a]") + ;; Char + ("chr" . "Int -> Char") + ("digitToInt" . "Char -> Int") + ("intToDigit" . "Int -> Char") + ("isAlpha" . "Char -> Bool") + ("isAlphaNum" . "Char -> Bool") + ("isAscii" . "Char -> Bool") + ("isControl" . "Char -> Bool") + ("isDigit" . "Char -> Bool") + ("isHexDigit" . "Char -> Bool") + ("isLatin1" . "Char -> Bool") + ("isLower" . "Char -> Bool") + ("isOctDigit" . "Char -> Bool") + ("isPrint" . "Char -> Bool") + ("isSpace" . "Char -> Bool") + ("isUpper" . "Char -> Bool") + ("lexLitChar" . "ReadS String") + ("ord" . "Char -> Int") + ("readLitChar" . "ReadS Char") + ("showLitChar" . "Char -> ShowS") + ("toLower" . "Char -> Char") + ("toUpper" . "Char -> Char") + ;; Monad + ("ap" . "Monad m => m (a -> b) -> m a -> m b") + ("filterM" . "Monad m => (a -> m Bool) -> [a] -> m [a]") + ("foldM" . "Monad m => (a -> b -> m a) -> a -> [b] -> m a") + ("guard" . "MonadPlus m => Bool -> m ()") + ("join" . "Monad m => m (m a) -> m a") + ("liftM" . "Monad m => (a -> b) -> (m a -> m b)") + ("liftM2" . "Monad m => (a -> b -> c) -> (m a -> m b -> m c)") + ("liftM3" . "Monad m => (a -> b -> c -> d) -> (m a -> m b -> m c -> m d)") + ("liftM4" . "Monad m => (a -> b -> c -> d -> e) -> (m a -> m b -> m c -> m d -> m e)") + ("liftM5" . "Monad m => (a -> b -> c -> d -> e -> f) -> (m a -> m b -> m c -> m d -> m e -> m f)") + ("mapAndUnzipM" . "Monad m => (a -> m (b,c)) -> [a] -> m ([b], [c])") + ("mplus" . "MonadPlus m => m a -> m a -> m a") + ("msum" . "MonadPlus m => [m a] -> m a") + ("mzero" . "MonadPlus m => m a") + ("unless" . "Monad m => Bool -> m () -> m ()") + ("when" . "Monad m => Bool -> m () -> m ()") + ("zipWithM" . "Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]") + ("zipWithM_" . "Monad m => (a -> b -> m c) -> [a] -> [b] -> m ()") + ;; IO + ("bracket" . "IO a -> (a -> IO b) -> (a -> IO c) -> IO c") + ("bracket_" . "IO a -> (a -> IO b) -> IO c -> IO c") + ("hClose" . "Handle -> IO ()") + ("hFileSize" . "Handle -> IO Integer") + ("hFlush" . "Handle -> IO ()") + ("hGetBuffering" . "Handle -> IO BufferMode") + ("hGetChar" . "Handle -> IO Char") + ("hGetContents" . "Handle -> IO String") + ("hGetLine" . "Handle -> IO String") + ("hGetPosn" . "Handle -> IO HandlePosn") + ("hIsClosed" . "Handle -> IO Bool") + ("hIsEOF" . "Handle -> IO Bool") + ("hIsOpen" . "Handle -> IO Bool") + ("hIsReadable" . "Handle -> IO Bool") + ("hIsSeekable" . "Handle -> IO Bool") + ("hIsWritable" . "Handle -> IO Bool") + ("hLookAhead" . "Handle -> IO Char") + ("hPrint" . "Show a => Handle -> a -> IO ()") + ("hPutChar" . "Handle -> Char -> IO ()") + ("hPutStr" . "Handle -> String -> IO ()") + ("hPutStrLn" . "Handle -> String -> IO ()") + ("hReady" . "Handle -> IO Bool") + ("hSeek" . "Handle -> SeekMode -> Integer -> IO ()") + ("hSetBuffering" . "Handle -> BufferMode -> IO ()") + ("hSetPosn" . "HandlePosn -> IO ()") + ("hWaitForInput" . "Handle -> Int -> IO Bool") + ("ioeGetErrorString" . "IOError -> String") + ("ioeGetFileName" . "IOError -> Maybe FilePath") + ("ioeGetHandle" . "IOError -> Maybe Handle") + ("isAlreadyExistsError" . "IOError -> Bool") + ("isAlreadyInUseError" . "IOError -> Bool") + ("isDoesNotExistError" . "IOError -> Bool") + ("isEOF" . "IO Bool") + ("isEOFError" . "IOError -> Bool") + ("isFullError" . "IOError -> Bool") + ("isIllegalOperation" . "IOError -> Bool") + ("isPermissionError" . "IOError -> Bool") + ("isUserError" . "IOError -> Bool") + ("openFile" . "FilePath -> IOMode -> IO Handle") + ("stderr" . "Handle") + ("stdin" . "Handle") + ("stdout" . "Handle") + ("try" . "IO a -> IO (Either IOError a)") + ;; Directory + ("createDirectory" . "FilePath -> IO ()") + ("doesDirectoryExist" . "FilePath -> IO Bool") + ("doesFileExist" . "FilePath -> IO Bool") + ("executable" . "Permissions -> Bool") + ("getCurrentDirectory" . "IO FilePath") + ("getDirectoryContents" . "FilePath -> IO [FilePath]") + ("getModificationTime" . "FilePath -> IO ClockTime") + ("getPermissions" . "FilePath -> IO Permissions") + ("readable" . "Permissions -> Bool") + ("removeDirectory" . "FilePath -> IO ()") + ("removeFile" . "FilePath -> IO ()") + ("renameDirectory" . "FilePath -> FilePath -> IO ()") + ("renameFile" . "FilePath -> FilePath -> IO ()") + ("searchable" . "Permissions -> Bool") + ("setCurrentDirectory" . "FilePath -> IO ()") + ("setPermissions" . "FilePath -> Permissions -> IO ()") + ("writable" . "Permissions -> Bool") + ;; System + ("exitFailure" . "IO a") + ("exitWith" . "ExitCode -> IO a") + ("getArgs" . "IO [String]") + ("getEnv" . "String -> IO String") + ("getProgName" . "IO String") + ("system" . "String -> IO ExitCode") + ;; Time + ("addToClockTime" . "TimeDiff -> ClockTime -> ClockTime") + ("calendarTimeToString" . "CalendarTime -> String") + ("ctDay" . "CalendarTime -> Int") + ("ctHour" . "CalendarTime -> Int") + ("ctIsDST" . "CalendarTime -> Bool") + ("ctMin" . "CalendarTime -> Int") + ("ctMonth" . "CalendarTime -> Month") + ("ctPicosec" . "CalendarTime -> Integer") + ("ctSec" . "CalendarTime -> Int") + ("ctTZ" . "CalendarTime -> Int") + ("ctTZName" . "CalendarTime -> String") + ("ctWDay" . "CalendarTime -> Day") + ("ctYDay" . "CalendarTime -> Int") + ("ctYear" . "CalendarTime -> Int") + ("diffClockTimes" . "ClockTime -> ClockTime -> TimeDiff") + ("formatCalendarTime" . "TimeLocale -> String -> CalendarTime -> String") + ("getClockTime" . "IO ClockTime") + ("tdDay" . "TimeDiff -> Int") + ("tdHour" . "TimeDiff -> Int") + ("tdMin" . "TimeDiff -> Int") + ("tdMonth" . "TimeDiff -> Int") + ("tdPicosec" . "TimeDiff -> Integer") + ("tdSec" . "TimeDiff -> Int") + ("tdYear" . "TimeDiff -> Int") + ("toCalendarTime" . "ClockTime -> IO CalendarTime") + ("toClockTime" . "CalendarTime -> ClockTime") + ("toUTCTime" . "ClockTime -> CalendarTime") + ;; Locale + ("amPm" . "TimeLocale -> (String, String)") + ("dateFmt" . "TimeLocale -> String") + ("dateTimeFmt" . "TimeLocale -> String") + ("defaultTimeLocale" . "TimeLocale") + ("months" . "TimeLocale -> [(String, String)]") + ("time12Fmt" . "TimeLocale -> String") + ("timeFmt" . "TimeLocale -> String") + ("wDays" . "TimeLocale -> [(String, String)]") + ;; CPUTime + ("cpuTimePrecision" . "Integer") + ("getCPUTime" . "IO Integer") + ;; Random + ("genRange" . "RandomGen g => g -> (Int, Int)") + ("getStdGen" . "IO StdGen") + ("getStdRandom" . "(StdGen -> (a, StdGen)) -> IO a") + ("mkStdGen" . "Int -> StdGen") + ("newStdGen" . "IO StdGen") + ("next" . "RandomGen g => g -> (Int, g)") + ("random" . "(Random a, RandomGen g) => g -> (a, g)") + ("randomIO" . "Random a => IO a") + ("randomR" . "(Random a, RandomGen g) => (a, a) -> g -> (a, g)") + ("randomRIO" . "Random a => (a,a) -> IO a") + ("randomRs" . "(Random a, RandomGen g) => (a, a) -> g -> [a]") + ("randoms" . "(Random a, RandomGen g) => g -> [a]") + ("setStdGen" . "StdGen -> IO ()") + ("split" . "RandomGen g => g -> (g, g)") + ) + "Alist of prelude functions and their types.") + + +(defvar haskell-doc-strategy-ids + (list + '("par" . "Done -> Done -> Done ; [infixr 0]") + '("seq" . "Done -> Done -> Done ; [infixr 1]") + + '("using" . "a -> Strategy a -> a ; [infixl 0]") + '("demanding" . "a -> Done -> a ; [infixl 0]") + '("sparking" . "a -> Done -> a ; [infixl 0]") + + '(">||" . "Done -> Done -> Done ; [infixr 2]") + '(">|" . "Done -> Done -> Done ; [infixr 3]") + '("$||" . "(a -> b) -> Strategy a -> a -> b ; [infixl 6]") + '("$|" . "(a -> b) -> Strategy a -> a -> b ; [infixl 6]") + '(".|" . "(b -> c) -> Strategy b -> (a -> b) -> (a -> c) ; [infixl 9]") + '(".||" . "(b -> c) -> Strategy b -> (a -> b) -> (a -> c) ; [infixl 9]") + '("-|" . "(a -> b) -> Strategy b -> (b -> c) -> (a -> c) ; [infixl 9]") + '("-||" . "(a -> b) -> Strategy b -> (b -> c) -> (a -> c) ; [infixl 9]") + + '("Done" . "type Done = ()") + '("Strategy" . "type Strategy a = a -> Done") + + '("r0" . "Strategy a") + '("rwhnf" . "Eval a => Strategy a") + '("rnf" . "Strategy a") + '("NFData" . "class Eval a => NFData a where rnf :: Strategy a") + '("NFDataIntegral" ."class (NFData a, Integral a) => NFDataIntegral a") + '("NFDataOrd" . "class (NFData a, Ord a) => NFDataOrd a") + + '("markStrat" . "Int -> Strategy a -> Strategy a") + + '("seqPair" . "Strategy a -> Strategy b -> Strategy (a,b)") + '("parPair" . "Strategy a -> Strategy b -> Strategy (a,b)") + '("seqTriple" . "Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)") + '("parTriple" . "Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)") + + '("parList" . "Strategy a -> Strategy [a]") + '("parListN" . "(Integral b) => b -> Strategy a -> Strategy [a]") + '("parListNth" . "Int -> Strategy a -> Strategy [a]") + '("parListChunk" . "Int -> Strategy a -> Strategy [a]") + '("parMap" . "Strategy b -> (a -> b) -> [a] -> [b]") + '("parFlatMap" . "Strategy [b] -> (a -> [b]) -> [a] -> [b]") + '("parZipWith" . "Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c]") + '("seqList" . "Strategy a -> Strategy [a]") + '("seqListN" . "(Integral a) => a -> Strategy b -> Strategy [b]") + '("seqListNth" . "Int -> Strategy b -> Strategy [b]") + + '("parBuffer" . "Int -> Strategy a -> [a] -> [a]") + + '("seqArr" . "(Ix b) => Strategy a -> Strategy (Array b a)") + '("parArr" . "(Ix b) => Strategy a -> Strategy (Array b a)") + + '("fstPairFstList" . "(NFData a) => Strategy [(a,b)]") + '("force" . "(NFData a) => a -> a ") + '("sforce" . "(NFData a) => a -> b -> b") + ) + "Alist of strategy functions and their types as defined in Strategies.lhs.") + +(defvar haskell-doc-user-defined-ids nil + "Alist of functions and strings defined by the user.") + + +(defsubst haskell-doc-is-of (fn types) + "Check whether FN is one of the functions in the alist TYPES and return the type." + (assoc fn types) ) + + +;; Put this minor mode on the global minor-mode-alist. +(or (assq 'haskell-doc-mode (default-value 'minor-mode-alist)) + (setq-default minor-mode-alist + (append (default-value 'minor-mode-alist) + '((haskell-doc-mode haskell-doc-minor-mode-string))))) + + +(defvar haskell-doc-keymap + (let ((map (make-sparse-keymap))) + (define-key map [visit] + '("Visit FTP home site" . haskell-doc-visit-home)) + (define-key map [submit] + '("Submit bug report" . haskell-doc-submit-bug-report)) + (define-key map [dummy] '("---" . nil)) + (define-key map [make-index] + '("Make global fct index" . haskell-doc-make-global-fct-index)) + (define-key map [global-types-on] + '("Toggle display of global types" . haskell-doc-show-global-types)) + (define-key map [strategy-on] + '("Toggle display of strategy ids" . haskell-doc-show-strategy)) + (define-key map [user-defined-on] + '("Toggle display of user defined ids" . haskell-doc-show-user-defined)) + (define-key map [prelude-on] + '("Toggle display of prelude functions" . haskell-doc-show-prelude)) + (define-key map [reserved-ids-on] + '("Toggle display of reserved ids" . haskell-doc-show-reserved)) + (define-key map [haskell-doc-on] + '("Toggle haskell-doc mode" . haskell-doc-mode)) + map)) + +(defun haskell-doc-install-keymap () + "Install a menu for `haskell-doc-mode' as a submenu of \"Hugs\"." + (interactive) + ;; Add the menu to the hugs menu as last entry. + (let ((hugsmap (lookup-key (current-local-map) [menu-bar Hugs]))) + (if (not (or (featurep 'xemacs) ; XEmacs has problems here + (not (keymapp hugsmap)) + (lookup-key hugsmap [haskell-doc]))) + (if (functionp 'define-key-after) + (define-key-after hugsmap [haskell-doc] + (cons "Haskell-doc" haskell-doc-keymap) + [Haskell-doc mode])))) + ;; Add shortcuts for these commands. + (local-set-key "\C-c\e/" 'haskell-doc-check-active) + ;; Conflicts with the binding of haskell-insert-otherwise. + ;; (local-set-key "\C-c\C-o" 'haskell-doc-mode) + (local-set-key [(control shift meta mouse-3)] + 'haskell-doc-ask-mouse-for-type)) + + +(defvar haskell-doc-timer nil) +(defvar haskell-doc-buffers nil) + +;;;###autoload +(defun haskell-doc-mode (&optional arg) + "Enter `haskell-doc-mode' for showing fct types in the echo area. +See variable docstring." + (interactive (list (or current-prefix-arg 'toggle))) + + (setq haskell-doc-mode + (cond + ((eq arg 'toggle) (not haskell-doc-mode)) + (arg (> (prefix-numeric-value arg) 0)) + (t))) + + ;; First, unconditionally turn the mode OFF. + + (setq haskell-doc-buffers (delq (current-buffer) haskell-doc-buffers)) + ;; Refresh the buffers list. + (dolist (buf haskell-doc-buffers) + (unless (and (buffer-live-p buf) + (with-current-buffer buf haskell-doc-mode)) + (setq haskell-doc-buffers (delq buf haskell-doc-buffers)))) + ;; Turn off the idle timer (or idle post-command-hook). + (when (and haskell-doc-timer (null haskell-doc-buffers)) + (cancel-timer haskell-doc-timer) + (setq haskell-doc-timer nil)) + (remove-hook 'post-command-hook + 'haskell-doc-mode-print-current-symbol-info 'local) + + (when haskell-doc-mode + ;; Turning the mode ON. + (push (current-buffer) haskell-doc-buffers) + + (if (fboundp 'run-with-idle-timer) + (unless haskell-doc-timer + (setq haskell-doc-timer + (run-with-idle-timer + haskell-doc-idle-delay t + 'haskell-doc-mode-print-current-symbol-info))) + (add-hook 'post-command-hook + 'haskell-doc-mode-print-current-symbol-info nil 'local)) + (and haskell-doc-show-global-types + (haskell-doc-make-global-fct-index)) ; build type index for global fcts + + (haskell-doc-install-keymap) + + (run-hooks 'haskell-doc-mode-hook)) + + (and (called-interactively-p 'any) + (message "haskell-doc-mode is %s" + (if haskell-doc-mode "enabled" "disabled"))) + haskell-doc-mode) + +(defmacro haskell-doc-toggle-var (id prefix) + ;; toggle variable or set it based on prefix value + `(setq ,id + (if ,prefix + (>= (prefix-numeric-value ,prefix) 0) + (not ,id))) ) + +(defun haskell-doc-show-global-types (&optional prefix) + "Turn on global types information in `haskell-doc-mode'." + (interactive "P") + (haskell-doc-toggle-var haskell-doc-show-global-types prefix) + (if haskell-doc-show-global-types + (haskell-doc-make-global-fct-index))) + +(defun haskell-doc-show-reserved (&optional prefix) + "Toggle the automatic display of a doc string for reserved ids." + (interactive "P") + (haskell-doc-toggle-var haskell-doc-show-reserved prefix)) + +(defun haskell-doc-show-prelude (&optional prefix) + "Toggle the automatic display of a doc string for reserved ids." + (interactive "P") + (haskell-doc-toggle-var haskell-doc-show-prelude prefix)) + +(defun haskell-doc-show-strategy (&optional prefix) + "Toggle the automatic display of a doc string for strategy ids." + (interactive "P") + (haskell-doc-toggle-var haskell-doc-show-strategy prefix)) + +(defun haskell-doc-show-user-defined (&optional prefix) + "Toggle the automatic display of a doc string for user defined ids." + (interactive "P") + (haskell-doc-toggle-var haskell-doc-show-user-defined prefix)) + + +;;;###autoload +(defalias 'turn-on-haskell-doc-mode 'haskell-doc-mode) +(make-obsolete 'turn-on-haskell-doc-mode + 'haskell-doc-mode + "2015-07-23") + +;;;###autoload +(defalias 'turn-on-haskell-doc 'haskell-doc-mode) +(make-obsolete 'turn-on-haskell-doc + 'haskell-doc-mode + "2015-07-23") + +(defalias 'turn-off-haskell-doc-mode 'turn-off-haskell-doc) + +(defun turn-off-haskell-doc () + "Unequivocally turn off `haskell-doc-mode' (which see)." + (haskell-doc-mode 0)) + +(defun haskell-doc-check-active () + "Check whether the print function is hooked in. +Should be the same as the value of `haskell-doc-mode' but alas currently it +is not." + (interactive) + (message "%s" + (if (or (and haskell-doc-mode haskell-doc-timer) + (memq 'haskell-doc-mode-print-current-symbol-info + post-command-hook)) + "haskell-doc is ACTIVE" + (substitute-command-keys + "haskell-doc is not ACTIVE \(Use \\[haskell-doc-mode] to turn it on\)")))) + + +;; This is the function hooked into the elisp command engine +(defun haskell-doc-mode-print-current-symbol-info () + "Print the type of the symbol under the cursor. + +This function is run by an idle timer to print the type + automatically if `haskell-doc-mode' is turned on." + (and haskell-doc-mode + (haskell-doc-in-code-p) + (not haskell-mode-interactive-prompt-state) + (not (eobp)) + (not executing-kbd-macro) + ;; Having this mode operate in the minibuffer makes it impossible to + ;; see what you're doing. + (not (eq (selected-window) (minibuffer-window))) + ;; not in string or comment + ;; take a nap, if run straight from post-command-hook. + (if (fboundp 'run-with-idle-timer) t + (sit-for haskell-doc-idle-delay)) + ;; good morning! read the word under the cursor for breakfast + (haskell-doc-show-type))) +;; ;; ToDo: find surrounding fct +;; (cond ((eq current-symbol current-fnsym) +;; (haskell-doc-show-type current-fnsym)) +;; (t +;; (or nil ; (haskell-doc-print-var-docstring current-symbol) +;; (haskell-doc-show-type current-fnsym))))))) + +;;;###autoload +(defun haskell-doc-current-info () + "Return the info about symbol at point. +Meant for `eldoc-documentation-function'." + ;; There are a number of possible documentation functions. + ;; Some of them are asynchronous. + (when (haskell-doc-in-code-p) + (let ((msg (or + (haskell-doc-current-info--interaction) + (haskell-doc-sym-doc (haskell-ident-at-point))))) + (unless (symbolp msg) msg)))) + +(defun haskell-doc-ask-mouse-for-type (event) + "Read the identifier under the mouse and echo its type. +This uses the same underlying function `haskell-doc-show-type' as the hooked +function. Only the user interface is different." + (interactive "e") + (save-excursion + (select-window (posn-window (event-end event))) + (goto-char (posn-point (event-end event))) + (haskell-doc-show-type))) + +(defun haskell-doc-in-code-p () + "A predicate indicating suitable case to show docs." + (not (or (and (eq haskell-literate 'bird) + ;; Copied from haskell-indent-bolp. + (<= (current-column) 2) + (eq (char-after (line-beginning-position)) ?\>)) + (nth 8 (syntax-ppss))))) + +;;;###autoload +(defun haskell-doc-show-type (&optional sym) + "Show the type of the function near point or given symbol SYM. +For the function under point, show the type in the echo area. +This information is extracted from the `haskell-doc-prelude-types' alist +of prelude functions and their types, or from the local functions in the +current buffer." + (interactive) + (unless sym (setq sym (haskell-ident-at-point))) + ;; if printed before do not print it again + (unless (string= sym (car haskell-doc-last-data)) + (let ((doc (or (haskell-doc-current-info--interaction t) + (haskell-doc-sym-doc sym)))) + (when (and doc (haskell-doc-in-code-p)) + ;; In Emacs 19.29 and later, and XEmacs 19.13 and later, all + ;; messages are recorded in a log. Do not put haskell-doc messages + ;; in that log since they are legion. + (let ((message-log-max nil)) + (message "%s" doc)))))) + +(defvar haskell-doc-current-info--interaction-last nil + "Async message stack. +If non-nil, a previous eldoc message from an async call, that +hasn't been displayed yet.") + +(defun haskell-doc-current-info--interaction (&optional sync) + "Asynchronous call to `haskell-process-get-type'. +Suitable for use in the eldoc function `haskell-doc-current-info'. + +If SYNC is non-nil, the call will be synchronous instead, and +instead of calling `eldoc-print-current-symbol-info', the result +will be returned directly." + ;; Return nil if nothing is available, or 'async if something might + ;; be available, but asynchronously later. This will call + ;; `eldoc-print-current-symbol-info' later. + (when (haskell-doc-in-code-p) + ;; do nothing when inside string or comment + (let (sym prev-message) + (cond + ((setq prev-message haskell-doc-current-info--interaction-last) + (setq haskell-doc-current-info--interaction-last nil) + (cdr prev-message)) + ((setq sym + (if (use-region-p) + (buffer-substring-no-properties + (region-beginning) (region-end)) + (haskell-ident-at-point))) + (if sync + (haskell-process-get-type sym #'identity t) + (haskell-process-get-type + sym (lambda (response) + (setq haskell-doc-current-info--interaction-last + (cons 'async response)) + (eldoc-print-current-symbol-info))))))))) + +(defun haskell-process-get-type (expr-string &optional callback sync) + "Asynchronously get the type of a given string. + +EXPR-STRING should be an expression passed to :type in ghci. + +CALLBACK will be called with a formatted type string. + +If SYNC is non-nil, make the call synchronously instead." + (unless callback (setq callback (lambda (response) (message "%s" response)))) + (let ((process (and (haskell-session-maybe) + (haskell-session-process (haskell-session-maybe)))) + ;; Avoid passing bad strings to ghci + (expr-okay + (and (not (string-match-p "\\`[[:space:]]*\\'" expr-string)) + (not (string-match-p "\n" expr-string)))) + (ghci-command (concat ":type " expr-string)) + (process-response + (lambda (response) + ;; Responses with empty first line are likely errors + (if (string-match-p (rx string-start line-end) response) + (setq response nil) + ;; Remove a newline at the end + (setq response (replace-regexp-in-string "\n\\'" "" response)) + ;; Propertize for eldoc + (save-match-data + (when (string-match " :: " response) + ;; Highlight type + (let ((name (substring response 0 (match-end 0))) + (type (propertize + (substring response (match-end 0)) + 'face 'eldoc-highlight-function-argument))) + (setq response (concat name type))))) + (when haskell-doc-prettify-types + (dolist (re '(("::" . "∷") ("=>" . "⇒") ("->" . "→"))) + (setq response + (replace-regexp-in-string (car re) (cdr re) response)))) + response)))) + (when (and process expr-okay) + (if sync + (let ((response (haskell-process-queue-sync-request process ghci-command))) + (funcall callback (funcall process-response response))) + (haskell-process-queue-command + process + (make-haskell-command + :go (lambda (_) (haskell-process-send-string process ghci-command)) + :complete + (lambda (_ response) + (funcall callback (funcall process-response response))))) + 'async)))) + +(defun haskell-doc-sym-doc (sym) + "Show the type of given symbol SYM. +For the function under point, show the type in the echo area. +This information is extracted from the `haskell-doc-prelude-types' alist +of prelude functions and their types, or from the local functions in the +current buffer. +If `haskell-doc-use-inf-haskell' is non-nil, this function will consult +the inferior Haskell process for type/kind information, rather than using +the haskell-doc database." + (if haskell-doc-use-inf-haskell + (unless (or (null sym) (string= "" sym)) + (let* ((message-log-max nil) + (result (ignore-errors + (unwind-protect + (inferior-haskell-type sym) + (message ""))))) + (if (and result (string-match " :: " result)) + result + (setq result (unwind-protect + (inferior-haskell-kind sym) + (message ""))) + (and result (string-match " :: " result) result)))) + (let ((i-am-prelude nil) + (i-am-fct nil) + (type nil) + (is-reserved (haskell-doc-is-of sym haskell-doc-reserved-ids)) + (is-prelude (haskell-doc-is-of sym haskell-doc-prelude-types)) + (is-strategy (haskell-doc-is-of sym haskell-doc-strategy-ids)) + (is-user-defined (haskell-doc-is-of sym haskell-doc-user-defined-ids))) + (cond + ;; if reserved id (i.e. Haskell keyword + ((and haskell-doc-show-reserved + is-reserved) + (setq type (cdr is-reserved)) + (setcdr haskell-doc-last-data type)) + ;; if built-in function get type from docstring + ((and (not (null haskell-doc-show-prelude)) + is-prelude) + (setq type (cdr is-prelude)) ; (cdr (assoc sym haskell-doc-prelude-types))) + (if (= 2 (length type)) ; horrible hack to remove bad formatting + (setq type (car (cdr type)))) + (setq i-am-prelude t) + (setq i-am-fct t) + (setcdr haskell-doc-last-data type)) + ((and haskell-doc-show-strategy + is-strategy) + (setq i-am-fct t) + (setq type (cdr is-strategy)) + (setcdr haskell-doc-last-data type)) + ((and haskell-doc-show-user-defined + is-user-defined) + ;; (setq i-am-fct t) + (setq type (cdr is-user-defined)) + (setcdr haskell-doc-last-data type)) + (t + (let ( (x (haskell-doc-get-and-format-fct-type sym)) ) + (if (null x) + (setcdr haskell-doc-last-data nil) ; if not found reset last data + (setq type (car x)) + (setq i-am-fct (string= "Variables" (cdr x))) + (if (and haskell-doc-show-global-types (null type)) + (setq type (haskell-doc-get-global-fct-type sym))) + (setcdr haskell-doc-last-data type)))) ) + ;; ToDo: encode i-am-fct info into alist of types + (and type + ;; drop `::' if it's not a fct + (let ( (str (cond ((and i-am-fct (not haskell-doc-chop-off-fctname)) + (format "%s :: %s" sym type)) + (t + (format "%s" type)))) ) + (if i-am-prelude + (add-text-properties 0 (length str) '(face bold) str)) + str))))) + + +;; ToDo: define your own notion of `near' to find surrounding fct +;;(defun haskell-doc-fnsym-in-current-sexp () +;; (let* ((p (point)) +;; (sym (progn +;; (forward-word -1) +;; (while (and (forward-word -1) ; (haskell-doc-forward-sexp-safe -1) +;; (> (point) (point-min)))) +;; (cond ((or (= (point) (point-min)) +;; (memq (or (char-after (point)) 0) +;; '(?\( ?\")) +;; ;; If we hit a quotation mark before a paren, we +;; ;; are inside a specific string, not a list of +;; ;; symbols. +;; (eq (or (char-after (1- (point))) 0) ?\")) +;; nil) +;; (t (condition-case nil +;; (read (current-buffer)) +;; (error nil))))))) +;; (goto-char p) +;; (if sym +;; (format "%s" sym) +;; sym))) + +;; (and (symbolp sym) +;; sym))) + + +;; ToDo: handle open brackets to decide if it's a wrapped type + +(defun haskell-doc-grab-line (fct-and-pos) + "Get the type of an \(FCT POSITION\) pair from the current buffer." + ;; (if (null fct-and-pos) + ;; "" ; fn is not a local fct + (let ( (str "")) + (goto-char (cdr fct-and-pos)) + (beginning-of-line) + ;; search for start of type (phsp give better bound?) + (if (null (search-forward "::" (+ (point) haskell-doc-search-distance) t)) + "" + (setq str (haskell-doc-grab)) ; leaves point at end of line + (while (haskell-doc-wrapped-type-p) ; while in a multi-line type expr + (forward-line 1) + (beginning-of-line) + (skip-chars-forward " \t") + (setq str (concat str (haskell-doc-grab)))) + (haskell-doc-string-nub-ws ; squeeze string + (if haskell-doc-chop-off-context ; no context + (haskell-doc-chop-off-context str) + str))))) +;; (concat (car fct-and-pos) "::" (haskell-doc-string-nub-ws str)))) + +(defun haskell-doc-wrapped-type-p () + "Check whether the type under the cursor is wrapped over several lines. +The cursor must be at the end of a line, which contains the type. +Currently, only the following is checked: +If this line ends with a `->' or the next starts with an `->' it is a +multi-line type \(same for `=>'\). +`--' comments are ignored. +ToDo: Check for matching parenthesis!." + (save-excursion + (let ( (here (point)) + (lim (progn (beginning-of-line) (point))) + ;; (foo "") + (res nil) + ) + (goto-char here) + (search-backward "--" lim t) ; skip over `--' comment + (skip-chars-backward " \t") + (if (bolp) ; skip empty lines + (progn + (forward-line 1) + (end-of-line) + (setq res (haskell-doc-wrapped-type-p))) + (forward-char -1) + ;; (setq foo (concat foo (char-to-string (preceding-char)) (char-to-string (following-char)))) + (if (or (and (or (char-equal (preceding-char) ?-) (char-equal (preceding-char) ?=)) + (char-equal (following-char) ?>)) ; (or -!> =!> + (char-equal (following-char) ?,)) ; !,) + (setq res t) + (forward-line) + (let ((here (point))) + (goto-char here) + (skip-chars-forward " \t") + (if (looking-at "--") ; it is a comment line + (progn + (forward-line 1) + (end-of-line) + (setq res (haskell-doc-wrapped-type-p))) + (forward-char 1) + ;; (setq foo (concat foo (char-to-string (preceding-char)) (char-to-string (following-char)))) + ;; (message "|%s|" foo) + (if (and (or (char-equal (preceding-char) ?-) (char-equal (preceding-char) ?=)) + (char-equal (following-char) ?>)) ; -!> or =!> + (setq res t)))))) + res))) + +(defun haskell-doc-grab () + "Return the text from point to the end of the line, chopping off comments. +Leaves point at end of line." + (let ((str (buffer-substring-no-properties + (point) (progn (end-of-line) (point))))) + (if (string-match "--" str) + (substring str 0 (match-beginning 0)) + str))) + +(defun haskell-doc-string-nub-ws (str) + "Replace all sequences of whitespace in STR by just one space. +ToDo: Also eliminate leading and trailing whitespace." + (let ((i -1)) + (while (setq i (string-match " [ \t\n]+\\|[\t\n]+" str (1+ i))) + (setq str (replace-match " " t t str))) + str)) + +(defun haskell-doc-chop-off-context (str) + "Eliminate the context in a type represented by the string STR." + (let ((i (string-match "=>" str)) ) + (if (null i) + str + (substring str (+ i 2))))) + +(defun haskell-doc-get-imenu-info (obj kind) + "Return a string describing OBJ of KIND \(Variables, Types, Data\)." + (cond + ((eq major-mode 'haskell-mode) + (let* ((imenu-info-alist (cdr (assoc kind imenu--index-alist))) + ;; (names (mapcar 'car imenu-info-alist)) + (x (assoc obj imenu-info-alist))) + (when x (haskell-doc-grab-line x)))) + + (t ;; (error "Cannot get local functions in %s mode, sorry" major-mode))) + nil))) + +;; ToDo: +;; - modular way of defining a mapping of module name to file +;; - use a path to search for file (not just current directory) + + +(defun haskell-doc-imported-list () + "Return a list of the imported modules in current buffer." + (interactive "fName of outer `include' file: ") ; (buffer-file-name)) + ;; Don't add current buffer to the imported file list if it is not (yet?) + ;; visiting a file since it leads to errors further down. + (let ((imported-file-list (and buffer-file-name (list buffer-file-name)))) + (widen) + (goto-char (point-min)) + (while (re-search-forward "^\\s-*import\\s-+\\([^ \t\n]+\\)" nil t) + (let ((basename (match-string 1))) + (dolist (ext '(".hs" ".lhs")) + (let ((file (concat basename ext))) + (if (file-exists-p file) + (push file imported-file-list)))))) + (nreverse imported-file-list) + ;;(message imported-file-list) + )) + +;; ToDo: generalise this to "Types" etc (not just "Variables") + +(defun haskell-doc-rescan-files (filelist) + "Do an `imenu' rescan on every file in FILELIST and return the fct-list. +This function switches to and potentially loads many buffers." + (save-current-buffer + (mapcar (lambda (f) + (set-buffer (find-file-noselect f)) + (imenu--make-index-alist t) + (cons f + (mapcar (lambda (x) + `(,(car x) . ,(haskell-doc-grab-line x))) + (cdr (assoc "Variables" imenu--index-alist))))) + filelist))) + +(defun haskell-doc-make-global-fct-index () + "Scan imported files for types of global fcts and update `haskell-doc-index'." + (interactive) + (setq haskell-doc-index + (haskell-doc-rescan-files (haskell-doc-imported-list)))) + +;; ToDo: use a separate munge-type function to format type concisely + +(defun haskell-doc-get-global-fct-type (&optional sym) + "Get type for function symbol SYM by examining `haskell-doc-index'." + (interactive) ; "fName of outer `include' file: \nsFct:") + (save-excursion + ;; (switch-to-buffer "*scratch*") + ;; (goto-char (point-max)) + ;; ;; Produces a list of fct-type alists + ;; (if (null sym) + ;; (setq sym (progn (forward-word -1) (read (current-buffer))))) + (or sym + (current-word)) + (let* ( (fn sym) ; (format "%s" sym)) + (fal haskell-doc-index) + (res "") ) + (while (not (null fal)) + (let* ( (l (car fal)) + (f (car l)) + (x (assoc fn (cdr l))) ) + (if (not (null x)) + (let* ( (ty (cdr x)) ; the type as string + (idx (string-match "::" ty)) + (str (if (null idx) + ty + (substring ty (+ idx 2)))) ) + (setq res (format "[%s] %s" f str)))) + (setq fal (cdr fal)))) + res))) ; (message res)) ) + +(defun haskell-doc-get-and-format-fct-type (fn) + "Get the type and kind of FN by checking local and global functions." + (save-excursion + (save-match-data + (let ((docstring "") + (doc nil) + ) + ;; is it a local function? + (setq docstring (haskell-doc-get-imenu-info fn "Variables")) + (if (not (null docstring)) + ;; (string-match (format "^%s\\s-+::\\s-+\\(.*\\)$" fn) docstring)) + (setq doc `(,docstring . "Variables"))) ; `(,(match-string 1 docstring) . "Variables") )) + ;; is it a type declaration? + (setq docstring (haskell-doc-get-imenu-info fn "Types")) + (if (not (null docstring)) + ;; (string-match (format "^\\s-*type\\s-+%s.*$" fn) docstring)) + (setq doc `(,docstring . "Types"))) ; `(,(match-string 0 docstring) . "Types")) ) + (if (not (null docstring)) + ;; (string-match (format "^\\s-*data.*%s.*$" fn) docstring)) + (setq doc `(,docstring . "Data"))) ; (setq doc `(,(match-string 0 docstring) . "Data")) ) + ;; return the result + doc )))) + +(defun inferior-haskell-kind (sym) + "Find the kind of SYM with `:kind' ghci feature." + (inferior-haskell-get-result (format ":kind %s" sym))) + +(defun inferior-haskell-type (sym) + "Find the type of SYM with `:type' ghci feature." + (inferior-haskell-get-result (format ":type (%s)" sym))) + +(provide 'haskell-doc) + +;;; haskell-doc.el ends here |