packages feed

hhp (empty) → 0.0.0

raw patch · 81 files changed

+4938/−0 lines, 81 filesdep +Cabaldep +basedep +containerssetup-changed

Dependencies added: Cabal, base, containers, deepseq, directory, doctest, filepath, ghc, ghc-boot, hhp, hlint, hspec, io-choice, process, syb

Files

+ ChangeLog view
@@ -0,0 +1,2 @@+2018-12-18 v0.0.0+	* First release
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elisp/Makefile view
@@ -0,0 +1,31 @@+SRCS = hhp.el hhp-func.el hhp-doc.el hhp-comp.el hhp-check.el hhp-process.el \+       hhp-command.el hhp-info.el hhp-ins-mod.el hhp-indent.el+EMACS = emacs+DETECT = xemacs++TEMPFILE  = temp.el++all: $(TEMPFILE) hhp.el+	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f hhp-compile+	rm -f $(TEMPFILE)++detect: $(TEMPFILE) hhp.el+	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f hhp-compile+	rm -f $(DETECT)++$(TEMPFILE):+	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE)+	@echo '(defun hhp-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE)+	@echo $(SRCS)| sed -e 's/\(hhp[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE)+	@echo ')))' >> $(TEMPFILE)++clean:+	rm -f *.elc $(TEMPFILE)++VERSION = `grep version hhp.el | sed -e 's/[^0-9\.]//g'`++bump:+	echo "(define-package\n  \"hhp\"\n  $(VERSION)\n  \"Sub mode for Haskell mode\"\n  nil)" > hhp-pkg.el++archive:+	git archive master -o ~/hhp-$(VERSION).tar --prefix=hhp-$(VERSION)/
+ elisp/hhp-check.el view
@@ -0,0 +1,353 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-check.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Mar  9, 2014++;;; Code:++(require 'hhp-func)+(require 'hhp-process)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++;; stolen from flymake.el+(defface hhp-face-error+  '((((supports :underline (:style wave)))+     :underline (:style wave :color "orangered"))+    (t+     :inherit error))+  "Face used for marking error lines."+  :group 'ghc)++(defface hhp-face-warn+  '((((supports :underline (:style wave)))+     :underline (:style wave :color "gold"))+    (t+     :inherit warning))+  "Face used for marking warning lines."+  :group 'ghc)++(defvar hhp-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))++(defvar hhp-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark)))++(defvar hhp-display-error nil+  "*An action to display errors/warnings for 'M-n' and 'M-p:++nil            does not display errors/warnings.+'minibuffer    displays errors/warnings in the minibuffer.+'other-buffer  displays errors/warnings in the other buffer.+")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-check-syntax ()+  (interactive)+  (hhp-with-process (hhp-check-send)+		    'hhp-check-callback+		    (lambda () (setq mode-line-process " -:-"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(hhp-defstruct hilit-info file line msg err)++(defun hhp-check-send ()+  (let ((file (buffer-file-name)))+    (if hhp-check-command+	(let ((opts (hhp-haskell-list-of-string hhp-hlint-options)))+	  (if opts+	      (format "lint %s %s\n" opts file)+	    (format "lint %s\n" file)))+      (format "check %s\n" file))))++(defun hhp-haskell-list-of-string (los)+  (when los+    (concat "["+	    (mapconcat (lambda (x) (concat "\"" x "\"")) los ", ")+	    "]")))++(defun hhp-check-callback (status)+  (cond+   ((eq status 'ok)+    (let* ((errs (hhp-read-lisp-this-buffer))+	   (infos (hhp-to-info errs)))+      (cond+       (infos+	(let ((file hhp-process-original-file)+	      (buf hhp-process-original-buffer))+	  (hhp-check-highlight-original-buffer file buf infos)))+       (t+	(hhp-with-current-buffer hhp-process-original-buffer+	  (remove-overlays (point-min) (point-max) 'hhp-check t))))+      (hhp-with-current-buffer hhp-process-original-buffer+	(let ((len (length infos)))+	  (if (= len 0)+	      (setq mode-line-process "")+	    (let* ((errs (hhp-filter 'hhp-hilit-info-get-err infos))+		   (elen (length errs))+		   (wlen (- len elen)))+	      (setq mode-line-process (format " %d:%d" elen wlen))))))))+   (t+    (hhp-with-current-buffer hhp-process-original-buffer+      (setq mode-line-process " failed")))))++(defun hhp-to-info (errs)+  ;; [^\t] to include \n.+  (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)")+	info infos)+    (dolist (err errs (nreverse infos))+      (when (string-match regex err)+	(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows+	       (line (string-to-number (match-string 2 err)))+	       ;; don't take column to make multiple same errors to a single.+	       (msg (match-string 4 err))+	       (wrn (string-match "^Warning" msg))+	       (info (hhp-make-hilit-info+		      :file file+		      :line line+		      :msg  msg+		      :err  (not wrn))))+	  (unless (member info infos)+	    (hhp-add infos info)))))))++(defun hhp-check-highlight-original-buffer (ofile buf infos)+  (hhp-with-current-buffer buf+    (remove-overlays (point-min) (point-max) 'hhp-check t)+    (save-excursion+      (goto-char (point-min))+      (dolist (info infos)+	(let ((line (hhp-hilit-info-get-line info))+	      (msg  (hhp-hilit-info-get-msg  info))+	      (file (hhp-hilit-info-get-file info))+	      (err  (hhp-hilit-info-get-err  info))+	      beg end ovl)+	  ;; FIXME: This is the Shlemiel painter's algorithm.+	  ;; If this is a bottleneck for a large code, let's fix.+	  (goto-char (point-min))+	  (cond+	   ((string= ofile file)+	    (forward-line (1- line))+	    (while (eq (char-after) 32) (forward-char))+	    (setq beg (point))+	    (forward-line)+	    (setq end (1- (point))))+	   (t+	    (setq beg (point))+	    (forward-line)+	    (setq end (point))))+	  (setq ovl (make-overlay beg end))+	  (overlay-put ovl 'hhp-check t)+	  (overlay-put ovl 'hhp-file file)+	  (overlay-put ovl 'hhp-msg msg)+	  (overlay-put ovl 'help-echo msg)+	  (let ((fringe (if err hhp-check-error-fringe hhp-check-warning-fringe))+		(face (if err 'hhp-face-error 'hhp-face-warn)))+	    (overlay-put ovl 'before-string fringe)+	    (overlay-put ovl 'face face)))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-overlay-p (ovl)+  (overlay-get ovl 'hhp-check))++(defun hhp-check-overlay-at (p)+  (hhp-filter 'hhp-overlay-p (overlays-at p)))++(hhp-defstruct file-msgs file msgs)++(defun hhp-get-errors-over-warnings ()+  (let ((ovls (hhp-check-overlay-at (point))))+    (when ovls+      (let ((msgs (mapcar (lambda (ovl) (overlay-get ovl 'hhp-msg)) ovls))+	    (file (overlay-get (car ovls) 'hhp-file))+	    errs wrns)+	(dolist (msg msgs)+	  (if (string-match "^Warning" msg)+	      (hhp-add wrns msg)+	    (hhp-add errs msg)))+	(hhp-make-file-msgs :file file :msgs (nconc errs wrns))))))++(defun hhp-display-errors ()+  (interactive)+  (let ((file-msgs (hhp-get-errors-over-warnings)))+    (if (null file-msgs)+	(message "No errors or warnings")+      (let ((file (hhp-file-msgs-get-file file-msgs))+	    (msgs (hhp-file-msgs-get-msgs file-msgs)))+	(hhp-display+	 nil+	 (lambda ()+	   (insert file "\n\n")+	   (mapc (lambda (x) (insert x "\n\n")) msgs)))))))++(defun hhp-display-errors-to-minibuf ()+  (let ((file-msgs (hhp-get-errors-over-warnings)))+    (if (null file-msgs)+	(message "No errors or warnings")+      (let* ((file (hhp-file-msgs-get-file file-msgs))+	     (msgs (hhp-file-msgs-get-msgs file-msgs))+	     (errmsg (mapconcat 'identity msgs "\n"))+	     (buffile buffer-file-name))+        (if (string-equal buffile file)+            (message "%s" errmsg)+          (message "%s\n\n%s" file errmsg))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-goto-prev-error ()+  (interactive)+  (let* ((here (point))+         (ovls0 (hhp-check-overlay-at here))+         (end (if ovls0 (overlay-start (car ovls0)) here))+         (ovls1 (overlays-in (point-min) end))+         (ovls2 (hhp-filter (lambda (ovl) (overlay-get ovl 'hhp-check)) ovls1))+         (pnts (mapcar 'overlay-start ovls2)))+    (if pnts (goto-char (apply 'max pnts))))+  (cond+   ((eq hhp-display-error 'minibuffer) (hhp-display-errors-to-minibuf))+   ((eq hhp-display-error 'other-buffer) (hhp-display-errors))))++(defun hhp-goto-next-error ()+  (interactive)+  (let* ((here (point))+         (ovls0 (hhp-check-overlay-at here))+         (beg (if ovls0 (overlay-end (car ovls0)) here))+         (ovls1 (overlays-in beg (point-max)))+         (ovls2 (hhp-filter (lambda (ovl) (overlay-get ovl 'hhp-check)) ovls1))+         (pnts (mapcar 'overlay-start ovls2)))+    (if pnts (goto-char (apply 'min pnts))))+  (cond+   ((eq hhp-display-error 'minibuffer) (hhp-display-errors-to-minibuf))+   ((eq hhp-display-error 'other-buffer) (hhp-display-errors))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-check-insert-from-warning ()+  (interactive)+  (dolist (data (mapcar (lambda (ovl) (overlay-get ovl 'hhp-msg)) (hhp-check-overlay-at (point))))+    (save-excursion+      (cond+       ((string-match "Inferred type: \\|no type signature:" data)+	(beginning-of-line)+	(insert-before-markers (hhp-extract-type data) "\n"))+       ((string-match "lacks an accompanying binding" data)+	(beginning-of-line)+	(when (looking-at "^\\([^ ]+\\) *::")+	  (save-match-data+	    (forward-line)+	    (if (not (bolp)) (insert "\n")))+	  (insert (match-string 1) " = undefined\n")))+       ;; GHC 7.8 uses Unicode for single-quotes.+       ((string-match "Not in scope: type constructor or class .\\([^\n]+\\)." data)+	(let ((sym (match-string 1 data)))+	  (hhp-ins-mod sym)))+       ((string-match "Not in scope: data constructor .\\([^\n]+\\)." data)+	;; if the type of data constructor, it would be nice.+	(let ((sym (match-string 1 data)))+	  (hhp-ins-mod sym)))+       ((string-match "\n[ ]+.\\([^ ]+\\). is a data constructor of .\\([^\n]+\\).\n" data)+	(let* ((old (match-string 1 data))+	       (type-const (match-string 2 data))+	       (new (format "%s(%s)" type-const old)))+	  (hhp-check-replace old new)))+       ((string-match "Not in scope: .\\([^\n]+\\)." data)+	(let ((sym (match-string 1 data)))+	  (if (or (string-match "\\." sym) ;; qualified+		  (y-or-n-p (format "Import module for %s?" sym)))+	      (hhp-ins-mod sym)+	    (unless (re-search-forward "^$" nil t)+	      (goto-char (point-max))+	      (insert "\n"))+	    (insert "\n" (hhp-enclose sym) " = undefined\n"))))+       ((string-match "Pattern match(es) are non-exhaustive" data)+	(let* ((fn (hhp-get-function-name))+	       (arity (hhp-get-function-arity fn)))+	  (hhp-insert-underscore fn arity)))+       ((string-match "Found:\n[ ]+\\([^\t]+\\)\nWhy not:\n[ ]+\\([^\t]+\\)" data)+	(let ((old (match-string 1 data))+	      (new (match-string 2 data)))+	  (hhp-check-replace old new)))+       (t+	(message "Nothing was done"))))))++(defun hhp-check-replace (old new)+  (beginning-of-line)+  (when (search-forward old nil t)+    (let ((end (point)))+      (search-backward old nil t)+      (delete-region (point) end))+    (insert new)))++(defun hhp-extract-type (str)+  (with-temp-buffer+    (insert str)+    (goto-char (point-min))+    (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\n +\\)?" nil t)+      (delete-region (point-min) (point)))+    (when (re-search-forward " forall [^.]+\\." nil t)+      (replace-match ""))+    (while (re-search-forward "\n +" nil t)+      (replace-match " "))+    (goto-char (point-min))+    (while (re-search-forward "\\[Char\\]" nil t)+      (replace-match "String"))+    (buffer-substring-no-properties (point-min) (point-max))))++(defun hhp-get-function-name ()+  (save-excursion+    (beginning-of-line)+    (when (looking-at "\\([^ ]+\\) ")+      (match-string 1))))++(defun hhp-get-function-arity (fn)+  (when fn+    (save-excursion+      (let ((regex (format "^%s *::" (regexp-quote fn))))+	(when (re-search-backward regex nil t)+	  (hhp-get-function-arity0))))))++(defun hhp-get-function-arity0 ()+  (let ((end (save-excursion (end-of-line) (point)))+	(arity 0))+    (while (search-forward "->" end t)+      (setq arity (1+ arity)))+    arity))++(defun hhp-insert-underscore (fn ar)+  (when fn+    (let ((arity (or ar 1)))+      (save-excursion+	(goto-char (point-max))+	(re-search-backward (format "^%s *::" (regexp-quote fn)))+	(forward-line)+	(re-search-forward "^$" nil t)+	(insert fn)+	(dotimes (i arity)+	  (insert " _"))+	(insert  " = error \"" fn "\"\n")))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-jump-file ()+  (interactive)+  (let* ((ovl (car (hhp-check-overlay-at 1)))+	 (file (if ovl (overlay-get ovl 'hhp-file))))+    (if file (find-file file))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar hhp-hlint-options nil "*Hlint options")++(defvar hhp-check-command nil)++(defun hhp-toggle-check-command ()+  (interactive)+  (setq hhp-check-command (not hhp-check-command))+  (if hhp-check-command+      (message "Syntax check with hlint")+    (message "Syntax check with GHC")))++(provide 'hhp-check)
+ elisp/hhp-command.el view
@@ -0,0 +1,96 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-command.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Apr 13, 2010++;;; Code:++(require 'hhp-process)+(require 'hhp-check)++(defun hhp-insert-template ()+  (interactive)+  (cond+   ((bobp)+    (hhp-insert-module-template))+   ((hhp-check-overlay-at (point))+    (hhp-check-insert-from-warning))+   (t+    (message "Nothing to be done"))))++(defun hhp-insert-module-template ()+  (let* ((fullpath (file-name-sans-extension (buffer-file-name)))+	 (rootdir (hhp-get-project-root))+	 (len (length rootdir))+	 (path (substring fullpath (1+ len)))+	 (file (file-name-sans-extension (buffer-name)))+	 (case-fold-search nil)+	 (modulep (lambda (x) (if (string-match "^[a-z]" x) nil x)))+	 (mod (if (string-match "^[a-z]" file)+		  "Main"+		(let* ((lst (split-string path "/"))+		       (lst-mod (delq nil (mapcar modulep lst))))+		  (mapconcat 'identity lst-mod ".")))))+    (while (looking-at "^{-#")+      (forward-line))+    (insert "module " mod " where\n")))++;; (defun hhp-capitalize (str)+;;   (let ((ret (copy-sequence str)))+;;     (aset ret 0 (upcase (aref ret 0)))+;;     ret))++(defun hhp-sort-lines (beg end)+  (interactive "r")+  (save-excursion+    (save-restriction+      (narrow-to-region beg end)+      (goto-char (point-min))+      (let ((inhibit-field-text-motion t))+        (sort-subr nil 'forward-line 'end-of-line+		   (lambda ()+		     (re-search-forward "^import\\( *qualified\\)? *" nil t)+		     nil)+		   'end-of-line))+      (hhp-merge-lines))))++(defun hhp-merge-lines ()+  (let ((case-fold-search nil))+    (goto-char (point-min))+    (while (not (eolp))+      ;; qualified modlues are not merged at this moment.+      ;; fixme if it is improper.+      (if (looking-at "^import *\\([A-Z][^ \n]+\\) *(\\(.*\\))$")+	  (let ((mod (match-string-no-properties 1))+		(syms (match-string-no-properties 2))+		(beg (point)))+	    (forward-line)+	    (hhp-merge-line beg mod syms))+	(forward-line)))))++(defun hhp-merge-line (beg mod syms)+  (let ((regex (concat "^import *" (regexp-quote mod) " *(\\(.*\\))$"))+	duplicated)+    (while (looking-at regex)+      (setq duplicated t)+      (setq syms (concat syms ", " (match-string-no-properties 1)))+      (forward-line))+    (when duplicated+      (delete-region beg (point))+      (insert "import " mod " (" syms ")\n"))))++(defun hhp-save-buffer ()+  (interactive)+  ;; fixme: better way then saving?+  (if hhp-check-command ;; hlint+      (if (buffer-modified-p)+	  (call-interactively 'save-buffer))+    (unless buffer-read-only+      (set-buffer-modified-p t)+      (call-interactively 'save-buffer)))+  (hhp-check-syntax))++(provide 'hhp-command)
+ elisp/hhp-comp.el view
@@ -0,0 +1,277 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-comp.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Sep 25, 2009++;;; Code:++(require 'hhp-func)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Customize Variables+;;;++(defvar hhp-idle-timer-interval 30+ "*Period of idle timer in second. When timeout, the names of+unloaded modules are loaded")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Constants+;;;++;; must be sorted+(defconst hhp-reserved-keyword-for-bol '("class" "data" "default" "import" "infix" "infixl" "infixr" "instance" "main" "module" "newtype" "type"))++;; must be sorted+(defconst hhp-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where"))++(defconst hhp-extra-keywords '("ByteString" "Text"))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Local Variables+;;;++(defvar hhp-window-configuration nil)++(mapc 'make-variable-buffer-local+      '(hhp-window-configuration))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Initializer+;;;++(defvar hhp-module-names nil)   ;; completion for "import"+(defvar hhp-merged-keyword nil) ;; completion for type/func/...+(defvar hhp-language-extensions nil)+(defvar hhp-option-flags nil)+(defvar hhp-pragma-names '("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "WARNING" "DEPRECATED" "INLINE" "NOINLINE" "ANN" "LINE" "RULES" "SPECIALIZE" "UNPACK" "SOURCE"))++(defconst hhp-keyword-prefix "hhp-keyword-")+(defvar hhp-keyword-Prelude nil)+(defvar hhp-keyword-Control.Applicative nil)+(defvar hhp-keyword-Control.Exception nil)+(defvar hhp-keyword-Control.Monad nil)+(defvar hhp-keyword-Data.Char nil)+(defvar hhp-keyword-Data.List nil)+(defvar hhp-keyword-Data.Maybe nil)+(defvar hhp-keyword-System.IO nil)++(defvar hhp-loaded-module nil)++(defun hhp-comp-init ()+  (let* ((syms '(hhp-module-names+		 hhp-language-extensions+		 hhp-option-flags+		 ;; hard coded in main.hs+		 hhp-keyword-Prelude+		 hhp-keyword-Control.Applicative+		 hhp-keyword-Control.Exception+		 hhp-keyword-Control.Monad+		 hhp-keyword-Data.Char+		 hhp-keyword-Data.List+		 hhp-keyword-Data.Maybe+		 hhp-keyword-System.IO))+	 (vals (hhp-boot (length syms))))+    (hhp-set syms vals))+  (hhp-add hhp-module-names "qualified")+  (hhp-add hhp-module-names "hiding")+  ;; hard coded in main.hs+  (hhp-merge-keywords '("Prelude"+			"Control.Applicative"+			"Control.Exception"+			"Control.Monad"+			"Data.Char"+			"Data.List"+			"Data.Maybe"+			"System.IO")))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Executing command+;;;++(defun hhp-boot (n)+  (prog2+      (message "Initializing...")+      (hhp-sync-process "boot\n" n)+    (message "Initializing...done")))++(defun hhp-load-modules (mods)+  (if mods+      (mapcar 'hhp-load-module mods)+    (message "No new modules")+    nil))++(defun hhp-load-module (mod)+  (prog2+      (message "Loading symbols for %s..." mod)+      (hhp-sync-process (format "browse %s\n" mod))+    (message "Loading symbols for %s...done" mod)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Completion+;;;++(defvar hhp-completion-buffer-name "*Completions*")++(defun hhp-complete ()+  (interactive)+  (if (hhp-should-scroll)+      (hhp-scroll-completion-buffer)+    (hhp-try-complete)))++(defun hhp-should-scroll ()+  (let ((window (hhp-completion-window)))+    (and (eq last-command this-command)+	 window (window-live-p window) (window-buffer window)+	 (buffer-name (window-buffer window)))))++(defun hhp-scroll-completion-buffer ()+  (let ((window (hhp-completion-window)))+    (with-current-buffer (window-buffer window)+      (if (pos-visible-in-window-p (point-max) window)+	  (set-window-start window (point-min))+	(save-selected-window+	  (select-window window)+	  (scroll-up))))))++(defun hhp-completion-window ()+  (get-buffer-window hhp-completion-buffer-name 0))++(defun hhp-try-complete ()+  (let* ((end (point))+	 (symbols (hhp-select-completion-symbol))+	 (beg (hhp-completion-start-point))+	 (pattern (buffer-substring-no-properties beg end))+	 (completion (try-completion pattern symbols)))+    (cond+     ((eq completion t) ;; completed+      ) ;; do nothing+     ((null completion) ;; no completions+      (ding))+     ((not (string= pattern completion)) ;; ???+      (delete-region beg end)+      (insert completion)+      (hhp-reset-window-configuration))+     (t ;; multiple completions+      (let* ((list0 (all-completions pattern symbols))+	     (list (sort list0 'string<)))+	(if (= (length list) 1)+	    (hhp-reset-window-configuration)+	  (hhp-save-window-configuration)+	  (with-output-to-temp-buffer hhp-completion-buffer-name+	    (display-completion-list list))))))))++(defun hhp-save-window-configuration ()+  (unless (get-buffer-window hhp-completion-buffer-name)+    (setq hhp-window-configuration (current-window-configuration))))++(defun hhp-reset-window-configuration ()+  (when hhp-window-configuration+    (set-window-configuration hhp-window-configuration)+    (setq hhp-window-configuration nil)))++(defun hhp-module-completion-p ()+  (or (minibufferp)+      (let ((end (point)))+	(save-excursion+	  (beginning-of-line)+	  (and (looking-at "import ")+	       (not (search-forward "(" end t)))))+      (save-excursion+	(beginning-of-line)+	(looking-at " +module "))))++(defun hhp-select-completion-symbol ()+  (cond+   ((hhp-module-completion-p)+    hhp-module-names)+   ((save-excursion+      (beginning-of-line)+      (looking-at "{-# LANGUAGE "))+    hhp-language-extensions)+   ((save-excursion+      (beginning-of-line)+      (looking-at "{-# OPTIONS_GHC "))+    hhp-option-flags)+   ((save-excursion+      (beginning-of-line)+      (looking-at "{-# "))+    hhp-pragma-names)+   ((or (bolp)+	(let ((end (point)))+	  (save-excursion+	    (beginning-of-line)+	    (not (search-forward " " end t)))))+    hhp-reserved-keyword-for-bol)+   (t hhp-merged-keyword)))++(defun hhp-completion-start-point ()+  (save-excursion+    (let ((beg (save-excursion (beginning-of-line) (point)))+	  (regex (if (hhp-module-completion-p) "[ (,`]" "[\[ (,`.]")))+      (if (re-search-backward regex beg t)+	  (1+ (point))+	beg))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Loading keywords+;;;++(defun hhp-import-module ()+  (interactive)+  (hhp-load-module-buffer))++(defun hhp-unloaded-modules (mods)+  (hhp-filter (lambda (mod)+		(and (member mod hhp-module-names)+		     (not (member mod hhp-loaded-module))))+	      mods))++(defun hhp-load-module-buffer ()+  (hhp-load-merge-modules (hhp-gather-import-modules-buffer)))++(defun hhp-load-merge-modules (mods)+  (let* ((umods (hhp-unloaded-modules mods))+	 (syms (mapcar 'hhp-module-symbol umods))+	 (names (hhp-load-modules umods)))+    (hhp-set syms names)+    (hhp-merge-keywords umods)))++(defun hhp-merge-keywords (mods)+  (setq hhp-loaded-module (append mods hhp-loaded-module))+  (let* ((modkeys (mapcar 'hhp-module-keyword hhp-loaded-module))+	 (keywords (cons hhp-extra-keywords (cons hhp-reserved-keyword modkeys)))+	 (uniq-sorted (sort (hhp-uniq-lol keywords) 'string<)))+    (setq hhp-merged-keyword uniq-sorted)))++(defun hhp-module-symbol (mod)+  (intern (concat hhp-keyword-prefix mod)))++(defun hhp-module-keyword (mod)+  (symbol-value (hhp-module-symbol mod)))++(defun hhp-gather-import-modules-buffer ()+  (let (ret)+    (save-excursion+      (goto-char (point-min))+      (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t)+	(hhp-add ret (match-string-no-properties 2))+	(forward-line)))+    ret))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Background Idle Timer+;;;++(provide 'hhp-comp)
+ elisp/hhp-doc.el view
@@ -0,0 +1,107 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-doc.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Sep 25, 2009++(require 'hhp-func)+(require 'hhp-comp)+(require 'hhp-info)++;;; Code:++(defun hhp-browse-document (&optional haskell-org)+  (interactive "P")+  (let ((mod0 (hhp-extract-module))+	(expr0 (hhp-things-at-point))+	pkg-ver-path mod expr info)+    (if (or mod0 (not expr0))+	(setq mod (hhp-read-module-name mod0))+      (setq expr (hhp-read-expression expr0))+      (setq info (hhp-get-info expr0))+      (setq mod (hhp-extact-module-from-info info)))+    (setq pkg-ver-path (hhp-resolve-document-path mod))+    (if (and pkg-ver-path mod)+	(hhp-display-document pkg-ver-path mod haskell-org expr)+      (message "No document found"))))++(hhp-defstruct pkg-ver-path pkg ver path)++(defun hhp-resolve-document-path (mod)+  (with-temp-buffer+    (hhp-call-process hhpc-command nil t nil "doc" mod)+    (goto-char (point-min))+    (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")+      (hhp-make-pkg-ver-path+       :pkg (match-string-no-properties 1)+       :ver (match-string-no-properties 2)+       :path (match-string-no-properties 4)))))++(defconst hhp-doc-local-format "file://%s/%s.html")+(defconst hhp-doc-hackage-format+  "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html")++(defun hhp-display-document (pkg-ver-path mod haskell-org &optional symbol)+  (let* ((mod- (hhp-replace-character mod ?. ?-))+	 (pkg  (hhp-pkg-ver-path-get-pkg pkg-ver-path))+	 (ver  (hhp-pkg-ver-path-get-ver pkg-ver-path))+	 (path (hhp-pkg-ver-path-get-path pkg-ver-path))+	 (pkg-with-ver (format "%s-%s" pkg ver))+	 (local (format hhp-doc-local-format path mod-))+	 (remote (format hhp-doc-hackage-format pkg ver mod-))+	 (file (format "%s/%s.html" path mod-))+	 (url0 (if (or haskell-org (not (file-exists-p file))) remote local))+	 (url (if symbol (hhp-add-anchor url0 symbol) url0)))+    ;; Mac's "open" removes the anchor from "file://", sigh.+    (browse-url url)))++(defun hhp-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:" (hhp-url-encode symbol))))))++(defun hhp-url-encode (symbol)+  (let ((len (length symbol))+	(i 0)+	acc)+    (while (< i len)+      (hhp-add acc (format "-%d-" (aref symbol i)))+      (setq i (1+ i)))+    (apply 'concat (nreverse acc))))++(defun hhp-extact-module-from-info (info)+  (when (string-match "\`\\([^']+\\)'" info)+    (match-string 1 info)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar hhp-input-map nil)++(unless hhp-input-map+  (setq hhp-input-map+	(if (boundp 'minibuffer-local-map)+	    (copy-keymap minibuffer-local-map)+	  (make-sparse-keymap)))+  (define-key hhp-input-map "\t" 'hhp-complete))++(defun hhp-read-module-name (def)+  (read-from-minibuffer "Module name: " def hhp-input-map))++(defun hhp-read-expression (def)+  (read-from-minibuffer "Expression: " def hhp-input-map))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-extract-module ()+  (interactive)+  (save-excursion+    (beginning-of-line)+    (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)")+	(match-string-no-properties 3))))++(provide 'hhp-doc)
+ elisp/hhp-func.el view
@@ -0,0 +1,216 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-func.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Sep 25, 2009++;;; Code:++(defvar hhpc-command "hhpc"+  "*The command name of \"hhpc\"")++(defvar hhp-ghc-options nil "*GHC options")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-replace-character (string from to)+  "Replace characters equal to FROM to TO in STRING."+  (let ((ret (copy-sequence string)))+    (dotimes (cnt (length ret) ret)+      (if (char-equal (aref ret cnt) from)+	  (aset ret cnt to)))))++(defun hhp-replace-character-buffer (from-c to-c)+  (let ((from (char-to-string from-c))+	(to (char-to-string to-c)))+    (save-excursion+      (goto-char (point-min))+      (while (search-forward from nil t)+	(replace-match to)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defmacro hhp-add (sym val)+  `(setq ,sym (cons ,val ,sym)))++(defun hhp-set (vars vals)+  (dolist (var vars)+    (if var (set var (car vals))) ;; var can be nil to skip+    (setq vals (cdr vals))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-filter (pred lst)+  (let (ret)+    (dolist (x lst (reverse ret))+      (if (funcall pred x) (hhp-add ret x)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-uniq-lol (lol)+  (let ((hash (make-hash-table :test 'equal))+	ret)+    (dolist (lst lol)+      (dolist (key lst)+	(puthash key key hash)))+    (maphash (lambda (key val) (hhp-add ret key)) hash)+    ret))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-read-lisp (func)+  (with-temp-buffer+    (funcall func)+    (hhp-read-lisp-this-buffer)))++;; OK/NG are ignored.+(defun hhp-read-lisp-this-buffer ()+  (save-excursion+    (goto-char (point-min))+    (condition-case nil+	(read (current-buffer))+      (error ()))))++(defun hhp-read-lisp-list-this-buffer (n)+  (save-excursion+    (goto-char (point-min))+    (condition-case nil+	(let ((m (set-marker (make-marker) 1 (current-buffer)))+	      ret)+	  (dotimes (i n (nreverse ret))+	    (hhp-add ret (read m))))+      (error ()))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-mapconcat (func list)+  (apply 'append (mapcar func list)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-things-at-point ()+  (thing-at-point 'sexp))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-keyword-number-pair (spec)+  (let ((len (length spec)) key ret)+    (dotimes (i len (nreverse ret))+      (setq key (intern (concat ":" (symbol-name (car spec)))))+      (setq ret (cons (cons key i) ret))+      (setq spec (cdr spec)))))++(defmacro hhp-defstruct (type &rest spec)+  `(progn+     (hhp-defstruct-constructor ,type ,@spec)+     (hhp-defstruct-s/getter ,type ,@spec)))++(defmacro hhp-defstruct-constructor (type &rest spec)+  `(defun ,(intern (concat "hhp-make-" (symbol-name type))) (&rest args)+     (let* ((alist (quote ,(hhp-keyword-number-pair spec)))+	    (struct (make-list (length alist) nil))+	    key val key-num)+       (while args ;; cannot use dolist+	 (setq key  (car args))+	 (setq args (cdr args))+	 (setq val  (car args))+	 (setq args (cdr args))+	 (unless (keywordp key)+	   (error "'%s' is not a keyword" key))+	 (setq key-num (assoc key alist))+	 (if key-num+	     (setcar (nthcdr (cdr key-num) struct) val)+	   (error "'%s' is unknown" key)))+       struct)))++(defmacro hhp-defstruct-s/getter (type &rest spec)+  `(let* ((type-name (symbol-name ',type))+	  (keys ',spec)+	  (len (length keys))+	  member-name setter getter)+     (dotimes (i len)+       (setq member-name (symbol-name (car keys)))+       (setq setter (intern (format "hhp-%s-set-%s" type-name member-name)))+       (fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct))+       (setq getter (intern (format "hhp-%s-get-%s" type-name member-name)))+       (fset getter (list 'lambda '(struct) (list 'nth i 'struct)))+       (setq keys (cdr keys)))))++(defun hhp-make-ghc-options ()+  (hhp-mapconcat (lambda (x) (list "-g" x)) hhp-ghc-options))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defconst hhp-error-buffer-name "*HHP Info*")++(defun hhp-display (fontify ins-func)+  (let ((buf hhp-error-buffer-name))+    (with-output-to-temp-buffer buf+      (with-current-buffer buf+        (erase-buffer)+        (funcall ins-func)+        (goto-char (point-min))+        (if (not fontify)+            (font-lock-mode -1)+          (haskell-font-lock-defaults-create)+	  (turn-on-font-lock)))+      (display-buffer buf))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-run-hhp (cmds &optional prog)+  (let ((target (or prog hhpc-command)))+    (hhp-executable-find target+      (let ((cdir default-directory))+	(with-temp-buffer+	  (cd cdir)+	  (apply 'hhp-call-process target nil t nil+		 (append (hhp-make-ghc-options) cmds))+	  (buffer-substring (point-min) (1- (point-max))))))))++(defmacro hhp-executable-find (cmd &rest body)+  ;; (declare (indent 1))+  `(if (not (executable-find ,cmd))+       (message "\"%s\" not found" ,cmd)+     ,@body))++(put 'hhp-executable-find 'lisp-indent-function 1)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar hhp-debug nil)++(defvar hhp-debug-buffer "*HHP Debug*")++(defmacro hhp-with-debug-buffer (&rest body)+  `(with-current-buffer (set-buffer (get-buffer-create hhp-debug-buffer))+     (goto-char (point-max))+     ,@body))++(defun hhp-call-process (cmd x y z &rest args)+  (apply 'call-process cmd x y z args)+  (when hhp-debug+    (let ((cbuf (current-buffer)))+      (hhp-with-debug-buffer+       (insert (format "%% %s %s\n" cmd (mapconcat 'identity args " ")))+       (insert-buffer-substring cbuf)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-enclose (expr)+  (let ((case-fold-search nil))+    (if (string-match "^[a-zA-Z0-9_]" expr)+	expr+      (concat "(" expr ")"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defmacro hhp-with-current-buffer (buf &rest body)+  ;; (declare (indent 1))+  `(if (buffer-live-p ,buf)+       (with-current-buffer ,buf+	 ,@body)))++(provide 'hhp-func)
+ elisp/hhp-indent.el view
@@ -0,0 +1,21 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-indent.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Feb 28, 2012++;;; Code:++(defvar hhp-indent-offset 4)++(defun hhp-make-indent-shallower (beg end)+  (interactive "r")+  (indent-rigidly (region-beginning) (region-end) (- hhp-indent-offset)))++(defun hhp-make-indent-deeper (beg end)+  (interactive "r")+  (indent-rigidly (region-beginning) (region-end) hhp-indent-offset))++(provide 'hhp-indent)
+ elisp/hhp-info.el view
@@ -0,0 +1,162 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-info.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Nov 15, 2010++;;; Code:++(require 'hhp-func)+(require 'hhp-process)++(defun hhp-show-info (&optional ask)+  (interactive "P")+  (let* ((expr0 (hhp-things-at-point))+	 (expr (if (or ask (not expr0)) (hhp-read-expression expr0) expr0))+	 (info (hhp-get-info expr)))+    (when info+      (hhp-display+       nil+       (lambda () (insert info))))))++(defun hhp-get-info (expr)+  (let* ((file (buffer-file-name))+	 (cmd (format "info %s %s\n" file expr)))+    (hhp-sync-process cmd)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; type+;;;++(defvar hhp-type-overlay nil)++(make-variable-buffer-local 'hhp-type-overlay)++(defun hhp-type-set-ix (n)+  (overlay-put hhp-type-overlay 'ix n))++(defun hhp-type-get-ix ()+  (overlay-get hhp-type-overlay 'ix))++(defun hhp-type-set-point (pos)+  (overlay-put hhp-type-overlay 'pos pos))++(defun hhp-type-get-point ()+  (overlay-get hhp-type-overlay 'pos))++(defun hhp-type-set-types (types)+  (overlay-put hhp-type-overlay 'types types))++(defun hhp-type-get-types ()+  (overlay-get hhp-type-overlay 'types))++(hhp-defstruct tinfo beg-line beg-column end-line end-column info)++(defun hhp-type-init ()+  (setq hhp-type-overlay (make-overlay 0 0))+  (overlay-put hhp-type-overlay 'face 'region)+  (hhp-type-clear-overlay)+  (setq after-change-functions+	(cons 'hhp-type-clear-overlay after-change-functions))+  (add-hook 'post-command-hook 'hhp-type-post-command-hook))++(defun hhp-type-clear-overlay (&optional beg end len)+  (when (overlayp hhp-type-overlay)+    (hhp-type-set-ix 0)+    (hhp-type-set-point 0)+    (move-overlay hhp-type-overlay 0 0)))++(defun hhp-type-post-command-hook ()+  (when (and (eq major-mode 'haskell-mode)+	     (overlayp hhp-type-overlay)+	     (/= (hhp-type-get-point) (point)))+    (hhp-type-clear-overlay)))++(defun hhp-show-type ()+  (interactive)+  (let ((buf (current-buffer))+	(tinfos (hhp-type-get-tinfos)))+    (if (null tinfos)+	(progn+	  (hhp-type-clear-overlay)+	  (message "Cannot guess type"))+      (let* ((tinfo (nth (hhp-type-get-ix) tinfos))+	     (type (hhp-tinfo-get-info tinfo))+	     (beg-line (hhp-tinfo-get-beg-line tinfo))+	     (beg-column (hhp-tinfo-get-beg-column tinfo))+	     (end-line (hhp-tinfo-get-end-line tinfo))+	     (end-column (hhp-tinfo-get-end-column tinfo))+	     (left (hhp-get-pos buf beg-line beg-column))+	     (right (hhp-get-pos buf end-line end-column)))+	(move-overlay hhp-type-overlay (- left 1) (- right 1) buf)+	(message type)))))++(defun hhp-type-get-tinfos ()+  (if (= (hhp-type-get-point) (point))+      (hhp-type-set-ix+       (mod (1+ (hhp-type-get-ix)) (length (hhp-type-get-types))))+    (let ((types (hhp-type-obtain-tinfos)))+      (if (not (listp types)) ;; main does not exist in Main+	  (hhp-type-set-types nil)+	(hhp-type-set-types types)+	(hhp-type-set-point (point))+	(hhp-type-set-ix 0))))+  (hhp-type-get-types))++(defun hhp-type-obtain-tinfos ()+  (let* ((ln (int-to-string (line-number-at-pos)))+	 (cn (int-to-string (1+ (current-column))))+	 (file (buffer-file-name))+	 (cmd (format "type %s %s %s\n" file ln cn)))+    (hhp-sync-process cmd nil 'hhp-type-fix-string)))++(defun hhp-type-fix-string ()+  (save-excursion+    (goto-char (point-min))+    (while (search-forward "[Char]" nil t)+      (replace-match "String"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Expanding Template Haskell+;;;++(defun hhp-expand-th ()+  (interactive)+  (let* ((file (buffer-file-name))+	 (cmds (list "expand" file "-b" "\n"))+	 (source (hhp-run-hhp cmds)))+    (when source+      (hhp-display+       'fontify+       (lambda () (insert source))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Misc+;;;++(defun hhp-get-pos (buf line col)+  (save-excursion+    (with-current-buffer buf+      (goto-char (point-min))+      (forward-line (1- line))+      (forward-char col)+      (point))))++(defun hhp-read-expression (default)+  (if default+      (let ((prompt (format "Expression (%s): " default)))+	(read-string prompt default nil))+    (read-string "Expression: ")))++(defun hhp-find-module-name ()+  (save-excursion+    (goto-char (point-min))+    (if (re-search-forward "^module[ ]+\\([^ \n]+\\)" nil t)+	(match-string-no-properties 1))))++(provide 'hhp-info)
+ elisp/hhp-ins-mod.el view
@@ -0,0 +1,79 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-ins-mod.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Dec 27, 2011++(require 'hhp-process)++;;; Code:++(defun hhp-insert-module ()+  (interactive)+  (let* ((expr0 (hhp-things-at-point))+	 (expr (hhp-read-expression expr0)))+    (hhp-ins-mod expr)))++(defvar hhp-preferred-modules '("Control.Applicative"+				"Data.ByteString"+				"Data.Text"+				"Text.Parsec"+				"System.FilePath"+				"System.Directory"))++(defun hhp-reorder-modules (mods)+  (catch 'loop+    (dolist (pmod hhp-preferred-modules)+      (if (member pmod mods)+	  (throw 'loop (cons pmod (delete pmod mods)))))+    mods))++(defun hhp-ins-mod (expr)+  (let (prefix fun mods)+    (if (not (string-match "^\\([^.]+\\)\\\.\\([^.]+\\)$" expr))+	(setq fun expr)+      (setq prefix (match-string 1 expr))+      (setq fun (match-string 2 expr)))+    (setq mods (hhp-reorder-modules (hhp-function-to-modules fun)))+    (if (null mods)+	(message "No module guessed")+      (let* ((key (or prefix fun))+	     (fmt (concat "Module name for \"" key "\" (%s): "))+	     (mod (hhp-completing-read fmt mods)))+	(save-excursion+	  (hhp-goto-module-position)+	  (if prefix+	      (insert-before-markers "import qualified " mod " as " prefix "\n")+	    (insert-before-markers "import " mod " (" (hhp-enclose expr) ")\n")))))))++(defun hhp-completing-read (fmt lst)+  (let* ((def (car lst))+	 (prompt (format fmt def))+	 (inp (completing-read prompt lst)))+    (if (string= inp "") def inp)))++(defun hhp-goto-module-position ()+  (goto-char (point-max))+  (if (re-search-backward "^import" nil t)+      (hhp-goto-empty-line)+    (if (not (re-search-backward "^module" nil t))+	(goto-char (point-min))+      (hhp-goto-empty-line)+      (forward-line)+      (unless (eolp)+	;; save-excursion is not proper due to insert-before-markers.+	(let ((beg (point)))+	  (insert-before-markers "\n")+	  (goto-char beg))))))++(defun hhp-goto-empty-line ()+  (unless (re-search-forward "^$" nil t)+    (forward-line)))++(defun hhp-function-to-modules (fun)+  (let ((cmd (format "find %s\n" fun)))+    (hhp-sync-process cmd)))++(provide 'hhp-ins-mod)
+ elisp/hhp-pkg.el view
@@ -0,0 +1,5 @@+(define-package+  "hhp"+  0.0.0+  "Sub mode for Haskell mode"+  nil)
+ elisp/hhp-process.el view
@@ -0,0 +1,149 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; hhp-process.el+;;;++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Mar  9, 2014++;;; Code:++(require 'hhp-func)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar hhp-process-running nil)++(defvar-local hhp-process-process-name nil)+(defvar-local hhp-process-original-buffer nil)+(defvar-local hhp-process-original-file nil)+(defvar-local hhp-process-callback nil)+(defvar-local hhp-process-hook nil)++(defvar hhpi-command "hhpi")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-get-project-root ()+  (hhp-run-hhp '("root")))++(defun hhp-with-process (cmd callback &optional hook1 hook2)+  (unless hhp-process-process-name+    (setq hhp-process-process-name (hhp-get-project-root)))+  (when (and hhp-process-process-name (not hhp-process-running))+    (setq hhp-process-running t)+    (if hook1 (funcall hook1))+    (let* ((cbuf (current-buffer))+	   (name hhp-process-process-name)+	   (buf (get-buffer-create (concat " hhpi:" name)))+	   (file (buffer-file-name))+	   (cpro (get-process name)))+      (hhp-with-current-buffer buf+        (setq hhp-process-original-buffer cbuf)+	(setq hhp-process-original-file file)+	(setq hhp-process-callback callback)+	(setq hhp-process-hook hook2)+	(erase-buffer)+	(let ((pro (hhp-get-process cpro name buf)))+	  (process-send-string pro cmd)+	  (when hhp-debug+	    (hhp-with-debug-buffer+	     (insert (format "%% %s" cmd))))+	  pro)))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-get-process (cpro name buf)+  (cond+   ((not cpro)+    (hhp-start-process name buf))+   ((not (eq (process-status cpro) 'run))+    (delete-process cpro)+    (hhp-start-process name buf))+   (t cpro)))++(defun hhp-start-process (name buf)+  (let* ((opts (append '("-b" "\n" "-l") (hhp-make-ghc-options)))+	 (pro (apply 'start-file-process name buf hhpi-command opts)))+    (set-process-filter pro 'hhp-process-filter)+    (set-process-sentinel pro 'hhp-process-sentinel)+    (set-process-query-on-exit-flag pro nil)+    pro))++(defun hhp-process-filter (process string)+  (let ((pbuf (process-buffer process)))+    (if (not (get-buffer pbuf))+	(setq hhp-process-running nil) ;; just in case+      (hhp-with-current-buffer (process-buffer process)+        (goto-char (point-max))+	(insert string)+	(forward-line -1)+	(cond+	 ((looking-at "^OK$")+	  (if hhp-process-hook (funcall hhp-process-hook))+	  (goto-char (point-min))+	  (funcall hhp-process-callback 'ok)+	  (when hhp-debug+	    (let ((cbuf (current-buffer)))+	      (hhp-with-debug-buffer+	       (insert-buffer-substring cbuf))))+	  (setq hhp-process-running nil))+	 ((looking-at "^NG ")+	  (funcall hhp-process-callback 'ng)+	  (when hhp-debug+	    (let ((cbuf (current-buffer)))+	      (hhp-with-debug-buffer+	       (insert-buffer-substring cbuf))))+	  (setq hhp-process-running nil)))))))++(defun hhp-process-sentinel (process event)+  (setq hhp-process-running nil))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defvar hhp-process-rendezvous nil)+(defvar hhp-process-num-of-results nil)+(defvar hhp-process-results nil)++(defun hhp-sync-process (cmd &optional n hook)+  (unless hhp-process-running+    (setq hhp-process-rendezvous nil)+    (setq hhp-process-results nil)+    (setq hhp-process-num-of-results (or n 1))+    (let ((pro (hhp-with-process cmd 'hhp-process-callback nil hook)))+      (condition-case nil+	  (while (null hhp-process-rendezvous)+	    ;; 0.01 is too fast for Emacs 24.4.+	    ;; (sit-for 0.1 t) may get stuck when tooltip is displayed.+	    (sit-for 0.1)+	    ;; (discard-input) avoids getting stuck.+	    (discard-input))+	(quit+	 (setq hhp-process-running nil))))+    hhp-process-results))++(defun hhp-process-callback (status)+  (cond+   ((eq status 'ok)+    (let* ((n hhp-process-num-of-results)+	   (ret (if (= n 1)+		    (hhp-read-lisp-this-buffer)+		  (hhp-read-lisp-list-this-buffer n))))+      (setq hhp-process-results ret)))+   (t+    (setq hhp-process-results nil)))+  (setq hhp-process-num-of-results nil)+  (setq hhp-process-rendezvous t))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hhp-kill-process ()+  (interactive)+  (let* ((name hhp-process-process-name)+	 (cpro (if name (get-process name))))+    (if (not cpro)+	(message "No process")+      (delete-process cpro)+      (message "A process was killed"))))++(provide 'hhp-process)
+ elisp/hhp.el view
@@ -0,0 +1,142 @@+;;; hhp.el --- hhp front-end for haskell-mode++;; Author:  Kazu Yamamoto <Kazu@Mew.org>+;; Created: Sep 25, 2009+;; Revised:++;; Put the following code to your "~/.emacs".+;;+;; (autoload 'hhp-init "hhp" nil t)+;; (autoload 'hhp-debug "hhp" nil t)+;; (add-hook 'haskell-mode-hook (lambda () (hhp-init)))+;;+;; Or if you wish to display error each goto next/prev error,+;; set hhp-display-error valiable.+;;+;; (setq hhp-display-error 'minibuffer) ; to minibuffer+;; ; (setq hhp-display-error 'other-buffer) ; to other-buffer++;;++;;; Code:++;; defvar-local was introduced in 24.3+(let* ((major 24)+       (minor 3))+  (if (or (< emacs-major-version major)+	  (and (= emacs-major-version major)+	       (< emacs-minor-version minor)))+      (error "hhp requires at least Emacs %d.%d" major minor)))++(defconst hhp-version "0.0.0")++;; (eval-when-compile+;;  (require 'haskell-mode))++(require 'hhp-comp)+(require 'hhp-doc)+(require 'hhp-info)+(require 'hhp-check)+(require 'hhp-command)+(require 'hhp-ins-mod)+(require 'hhp-indent)+(require 'dabbrev)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Customize Variables+;;;++(defun hhp-find-C-h ()+  (or+   (when keyboard-translate-table+     (aref keyboard-translate-table ?\C-h))+   ?\C-h))++(defvar hhp-completion-key  "\e\t")+(defvar hhp-document-key    "\e\C-d")+(defvar hhp-import-key      "\e\C-m")+(defvar hhp-previous-key    "\ep")+(defvar hhp-next-key        "\en")+(defvar hhp-help-key        "\e?")+(defvar hhp-insert-key      "\et")+(defvar hhp-sort-key        "\es")+(defvar hhp-type-key        "\C-c\C-t")+(defvar hhp-info-key        "\C-c\C-i")+(defvar hhp-check-key       "\C-x\C-s")+(defvar hhp-toggle-key      "\C-c\C-c")+(defvar hhp-jump-key        "\C-c\C-j")+(defvar hhp-module-key      "\C-c\C-m")+(defvar hhp-expand-key      "\C-c\C-e")+(defvar hhp-kill-key        "\C-c\C-k")+(defvar hhp-hoogle-key      (format "\C-c%c" (hhp-find-C-h)))+(defvar hhp-shallower-key   "\C-c<")+(defvar hhp-deeper-key      "\C-c>")++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Initializer+;;;++(defvar hhp-initialized nil)++;;;###autoload+(defun hhp-init ()+  (hhp-abbrev-init)+  (hhp-type-init)+  (unless hhp-initialized+    (define-key haskell-mode-map hhp-completion-key  'hhp-complete)+    (define-key haskell-mode-map hhp-document-key    'hhp-browse-document)+    (define-key haskell-mode-map hhp-type-key        'hhp-show-type)+    (define-key haskell-mode-map hhp-info-key        'hhp-show-info)+    (define-key haskell-mode-map hhp-expand-key      'hhp-expand-th)+    (define-key haskell-mode-map hhp-import-key      'hhp-import-module)+    (define-key haskell-mode-map hhp-previous-key    'hhp-goto-prev-error)+    (define-key haskell-mode-map hhp-next-key        'hhp-goto-next-error)+    (define-key haskell-mode-map hhp-help-key        'hhp-display-errors)+    (define-key haskell-mode-map hhp-insert-key      'hhp-insert-template)+    (define-key haskell-mode-map hhp-sort-key        'hhp-sort-lines)+    (define-key haskell-mode-map hhp-check-key       'hhp-save-buffer)+    (define-key haskell-mode-map hhp-toggle-key      'hhp-toggle-check-command)+    (define-key haskell-mode-map hhp-jump-key        'hhp-jump-file)+    (define-key haskell-mode-map hhp-module-key      'hhp-insert-module)+    (define-key haskell-mode-map hhp-kill-key        'hhp-kill-process)+    (define-key haskell-mode-map hhp-hoogle-key      'haskell-hoogle)+    (define-key haskell-mode-map hhp-shallower-key   'hhp-make-indent-shallower)+    (define-key haskell-mode-map hhp-deeper-key      'hhp-make-indent-deeper)+    (hhp-comp-init)+    (setq hhp-initialized t))+  (hhp-import-module)+  (hhp-check-syntax))++(defun hhp-abbrev-init ()+  (set (make-local-variable 'dabbrev-case-fold-search) nil))++;;;###autoload+(defun hhp-debug ()+  (interactive)+  (let ((el-path (locate-file "hhp.el" load-path))+	(ghc-path (executable-find "ghc")) ;; FIXME+	(hhpc-path (executable-find hhpc-command))+	(hhpi-path (executable-find hhpi-command))+	(el-ver hhp-version)+	(ghc-ver (hhp-run-hhp '("--version") "ghc"))+	(hhp-ver (hhp-run-hhp '("version")))+	(hhpi-ver (hhp-run-hhp '("version") hhpi-command))+	(path (getenv "PATH")))+    (switch-to-buffer (get-buffer-create "**HHP Debug**"))+    (erase-buffer)+    (insert "Path: check if you are using intended programs.\n")+    (insert (format "\t  hhp.el path: %s\n" el-path))+    (insert (format "\t    hhpc path: %s\n" hhpc-path))+    (insert (format "\t    hhpi path: %s\n" hhpi-path))+    (insert (format "\t     ghc path: %s\n" ghc-path))+    (insert "\nVersion: all versions must be the same.\n")+    (insert (format "\thhp.el version %s\n" el-ver))+    (insert (format "\t  %s\n" hhp-ver))+    (insert (format "\t  %s\n" hhpi-ver))+    (insert (format "\t%s\n"  ghc-ver))+    (insert "\nEnvironment variables:\n")+    (insert (format "\tPATH=%s\n" path))))++(provide 'hhp)
+ hhp.cabal view
@@ -0,0 +1,176 @@+Name:                   hhp+Version:                0.0.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Homepage:               https://github.com/kazu-yamamoto/hhp+Synopsis:               Happy Haskell Programming+Description:            The hhp command is a backend command to enrich+                        Haskell programming on editors.+                        The hhpc/hhpi commands are based on HHP library+                        which is a wrapper of GHC API and Cabal API.+                        This package includes the hhpc command,+                        the hhpi command,+                        the HHP library, and Emacs front-end.+                        For more information, please see its home page.++Category:               Development+Cabal-Version:          >= 1.10+Build-Type:             Simple+Data-Dir:               elisp+Data-Files:             Makefile hhp.el hhp-func.el hhp-doc.el hhp-comp.el+                        hhp-check.el hhp-process.el hhp-command.el hhp-info.el+                        hhp-ins-mod.el hhp-indent.el hhp-pkg.el+Extra-Source-Files:     ChangeLog+                        test/data/*.cabal+                        test/data/*.hs+                        test/data/cabal.sandbox.config.in+                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf+                        test/data/broken-cabal/*.cabal+                        test/data/broken-sandbox/*.cabal+                        test/data/broken-sandbox/cabal.sandbox.config+                        test/data/check-test-subdir/*.cabal+                        test/data/check-test-subdir/src/Check/Test/*.hs+                        test/data/check-test-subdir/test/*.hs+                        test/data/check-test-subdir/test/Bar/*.hs+                        test/data/check-packageid/cabal.sandbox.config.in+                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf+                        test/data/hhp-check/*.cabal+                        test/data/hhp-check/*.hs+                        test/data/hhp-check/Data/*.hs+                        test/data/subdir1/subdir2/dummy++Library+  Default-Language:     Haskell2010+  GHC-Options:          -Wall+  HS-Source-Dirs:       lib+  Exposed-Modules:      Hhp+                        Hhp.Ghc+                        Hhp.Internal+  Other-Modules:        Hhp.Boot+                        Hhp.Browse+                        Hhp.CabalApi+                        Hhp.Check+                        Hhp.Cradle+                        Hhp.Debug+                        Hhp.Doc+                        Hhp.Find+                        Hhp.Flag+                        Hhp.GHCApi+                        Hhp.Gap+                        Hhp.GhcPkg+                        Hhp.Logger+                        Hhp.Info+                        Hhp.Lang+                        Hhp.Lint+                        Hhp.List+                        Hhp.PkgDoc+                        Hhp.Syb+                        Hhp.Types+                        Hhp.Things+  Build-Depends:        base >= 4.9 && < 5+                      , Cabal >= 1.24+                      , containers+                      , deepseq+                      , directory+                      , filepath+                      , ghc+                      , hlint >= 1.8.61+                      , io-choice+                      , process+                      , syb+  if impl(ghc < 8.2)+    Build-Depends:      ghc-boot++Executable hhpc+  Default-Language:     Haskell2010+  Main-Is:              hhpc.hs+  Other-Modules:        Paths_hhp+  GHC-Options:          -Wall+  HS-Source-Dirs:       src+  Build-Depends:        base >= 4.9 && < 5+                      , directory+                      , filepath+                      , ghc+                      , hhp++Executable hhpi+  Default-Language:     Haskell2010+  Main-Is:              hhpi.hs+  Other-Modules:        Paths_hhp+  GHC-Options:          -Wall+  HS-Source-Dirs:       src+  Build-Depends:        base >= 4.9 && < 5+                      , containers+                      , directory+                      , filepath+                      , ghc+                      , hhp++Test-Suite doctest+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       test+  Ghc-Options:          -Wall+  Main-Is:              doctests.hs+  Build-Depends:        base+                      , doctest >= 0.9.3++Test-Suite spec+  Default-Language:     Haskell2010+  Main-Is:              Main.hs+  Hs-Source-Dirs:       test, lib+  GHC-Options:          -Wall+  Type:                 exitcode-stdio-1.0+  Other-Modules:        Dir+                        Spec+                        BrowseSpec+                        CabalApiSpec+                        CheckSpec+                        FlagSpec+                        InfoSpec+                        LangSpec+                        LintSpec+                        ListSpec+                        GhcPkgSpec+  Other-Modules:        Hhp+                        Hhp.Boot+                        Hhp.Browse+                        Hhp.CabalApi+                        Hhp.Check+                        Hhp.Cradle+                        Hhp.Debug+                        Hhp.Doc+                        Hhp.Find+                        Hhp.Flag+                        Hhp.GHCApi+                        Hhp.Gap+                        Hhp.GhcPkg+                        Hhp.Info+                        Hhp.Lang+                        Hhp.Lint+                        Hhp.List+                        Hhp.Logger+                        Hhp.PkgDoc+                        Hhp.Syb+                        Hhp.Types+                        Hhp.Things+  Build-Depends:        base >= 4.9 && < 5+                      , Cabal >= 1.24+                      , containers+                      , deepseq+                      , directory+                      , filepath+                      , ghc+                      , hspec >= 1.7.1+                      , io-choice+                      , process+                      , syb+                      , hlint >= 1.7.1+  if impl(ghc < 8.2)+    Build-Depends:      ghc-boot++Source-Repository head+  Type:                 git+  Location:             git://github.com/kazu-yamamoto/hhp.git
+ lib/Hhp.hs view
@@ -0,0 +1,45 @@+-- | The Happy Haskell Programming library.+--   API for commands.++module Hhp (+  -- * Cradle+    Cradle(..)+  , findCradle+  -- * Options+  , Options(..)+  , LineSeparator(..)+  , OutputStyle(..)+  , defaultOptions+  -- * Types+  , ModuleString+  , Expression+  -- * 'IO' utilities+  , bootInfo+  , browseModule+  , checkSyntax+  , lintSyntax+  , expandTemplate+  , infoExpr+  , typeExpr+  , listModules+  , listLanguages+  , listFlags+  , debugInfo+  , rootInfo+  , packageDoc+  , findSymbol+  ) where++import Hhp.Boot+import Hhp.Browse+import Hhp.Check+import Hhp.Cradle+import Hhp.Debug+import Hhp.Find+import Hhp.Flag+import Hhp.Info+import Hhp.Lang+import Hhp.Lint+import Hhp.List+import Hhp.PkgDoc+import Hhp.Types
+ lib/Hhp/Boot.hs view
@@ -0,0 +1,38 @@+module Hhp.Boot where++import CoreMonad (liftIO)+import GHC (Ghc)++import Hhp.Browse+import Hhp.Flag+import Hhp.GHCApi+import Hhp.Lang+import Hhp.List+import Hhp.Types++-- | Printing necessary information for front-end booting.+bootInfo :: Options -> Cradle -> IO String+bootInfo opt cradle = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    boot opt++-- | Printing necessary information for front-end booting.+boot :: Options -> Ghc String+boot opt = do+    mods  <- modules opt+    langs <- liftIO $ listLanguages opt+    flags <- liftIO $ listFlags opt+    pre   <- concat <$> mapM (browse opt) preBrowsedModules+    return $ mods ++ langs ++ flags ++ pre++preBrowsedModules :: [String]+preBrowsedModules = [+    "Prelude"+  , "Control.Applicative"+  , "Control.Exception"+  , "Control.Monad"+  , "Data.Char"+  , "Data.List"+  , "Data.Maybe"+  , "System.IO"+  ]
+ lib/Hhp/Browse.hs view
@@ -0,0 +1,146 @@+module Hhp.Browse (+    browseModule+  , browse+  ) where++import Exception (ghandle)+import FastString (mkFastString)+import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)+import qualified GHC as G+import Name (getOccString)+import Outputable (ppr, Outputable)+import TyCon (isAlgTyCon)+import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)++import Control.Exception (SomeException(..))+import Data.Char (isAlpha)+import Data.List (sort)+import Data.Maybe (catMaybes)++import Hhp.Doc (showPage, styleUnqualified)+import Hhp.GHCApi+import Hhp.Things+import Hhp.Types++----------------------------------------------------------------++-- | Getting functions, classes, etc from a module.+--   If 'detailed' is 'True', their types are also obtained.+--   If 'operators' is 'True', operators are also returned.+browseModule :: Options+             -> Cradle+             -> ModuleString -- ^ A module name. (e.g. \"Data.List\")+             -> IO String+browseModule opt cradle pkgmdl = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    browse opt pkgmdl++-- | Getting functions, classes, etc from a module.+--   If 'detailed' is 'True', their types are also obtained.+--   If 'operators' is 'True', operators are also returned.+browse :: Options+       -> ModuleString -- ^ A module name. (e.g. \"Data.List\")+       -> Ghc String+browse opt pkgmdl = do+    convert opt . sort <$> (getModule >>= listExports)+  where+    (mpkg,mdl) = splitPkgMdl pkgmdl+    mdlname = G.mkModuleName mdl+    mpkgid = mkFastString <$> mpkg+    listExports Nothing       = return []+    listExports (Just mdinfo) = processExports opt mdinfo+    -- findModule works only for package modules, moreover,+    -- you cannot load a package module. On the other hand,+    -- to browse a local module you need to load it first.+    -- If CmdLineError is signalled, we assume the user+    -- tried browsing a local module.+    getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler+    browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo+    browseLocalModule = ghandle handler $ do+      setTargetFiles [mdl]+      G.findModule mdlname Nothing >>= G.getModuleInfo+    fallback (CmdLineError _) = browseLocalModule+    fallback _                = return Nothing+    handler (SomeException _) = return Nothing+-- |+--+-- >>> splitPkgMdl "base:Prelude"+-- (Just "base","Prelude")+-- >>> splitPkgMdl "Prelude"+-- (Nothing,"Prelude")+splitPkgMdl :: String -> (Maybe String,String)+splitPkgMdl pkgmdl = case break (==':') pkgmdl of+    (mdl,"")    -> (Nothing,mdl)+    (pkg,_:mdl) -> (Just pkg,mdl)++processExports :: Options -> ModuleInfo -> Ghc [String]+processExports opt minfo = mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo+  where+    removeOps+      | operators opt = id+      | otherwise = filter (isAlpha . head . getOccString)++showExport :: Options -> ModuleInfo -> Name -> Ghc String+showExport opt minfo e = do+  mtype' <- mtype+  return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']+  where+    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt+    mtype+      | detailed opt = do+        tyInfo <- G.modInfoLookupName minfo e+        -- If nothing found, load dependent module and lookup global+        tyResult <- maybe (inOtherModule e) (return . Just) tyInfo+        dflag <- G.getSessionDynFlags+        return $ do+          typeName <- tyResult >>= showThing dflag+          (" :: " ++ typeName) `justIf` detailed opt+      | otherwise = return Nothing+    formatOp nm@(n:_)+      | isAlpha n = nm+      | otherwise = "(" ++ nm ++ ")"+    formatOp "" = error "formatOp"+    inOtherModule :: Name -> Ghc (Maybe TyThing)+    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm+    justIf :: a -> Bool -> Maybe a+    justIf x True = Just x+    justIf _ False = Nothing++showThing :: DynFlags -> TyThing -> Maybe String+showThing dflag tything = showThing' dflag (fromTyThing tything)++showThing' :: DynFlags -> GapThing -> Maybe String+showThing' dflag (GtA a) = Just $ formatType dflag a+showThing' _     (GtT t) = unwords . toList <$> tyType t+  where+    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)+showThing' _     _       = Nothing++formatType :: DynFlags -> Type -> String+formatType dflag a = showOutputable dflag (removeForAlls a)++tyType :: TyCon -> Maybe String+tyType typ+    | isAlgTyCon typ+      && not (G.isNewTyCon typ)+      && not (G.isClassTyCon typ) = Just "data"+    | G.isNewTyCon typ            = Just "newtype"+    | G.isClassTyCon typ          = Just "class"+--    | G.isSynTyCon typ            = Just "type" -- fixme+    | G.isTypeSynonymTyCon typ    = Just "type"+    | otherwise                   = Nothing++removeForAlls :: Type -> Type+removeForAlls ty = removeForAlls' ty' tty'+  where+    ty'  = dropForAlls ty+    tty' = splitFunTy_maybe ty'++removeForAlls' :: Type -> Maybe (Type, Type) -> Type+removeForAlls' ty Nothing = ty+removeForAlls' ty (Just (pre, ftype))+    | isPredTy pre        = mkFunTy pre (dropForAlls ftype)+    | otherwise           = ty++showOutputable :: Outputable a => DynFlags -> a -> String+showOutputable dflag = unwords . lines . showPage dflag (styleUnqualified dflag) . ppr
+ lib/Hhp/CabalApi.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings, CPP #-}++module Hhp.CabalApi (+    getCompilerOptions+  , parseCabalFile+  , cabalAllBuildInfo+  , cabalDependPackages+  , cabalSourceDirs+  , cabalAllTargets+  ) where++import Distribution.Compiler (unknownCompilerInfo, AbiTag(NoAbiTag))+import Distribution.ModuleName (ModuleName,toFilePath)+import Distribution.Package (Dependency(Dependency))+import qualified Distribution.Package as C+import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)+import qualified Distribution.PackageDescription as P+import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))+import Distribution.Simple.Program (ghcProgram)+import Distribution.Simple.Program.Types (programName, programFindVersion)+import Distribution.System (buildPlatform)+import Distribution.Text (display)+import Distribution.Verbosity (silent)+import Distribution.Version (Version)++#if MIN_VERSION_Cabal(2,2,0)+import Distribution.PackageDescription.Configuration (finalizePD)+import Distribution.PackageDescription.Parsec (readGenericPackageDescription)+import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec)+import Distribution.Types.GenericPackageDescription (mkFlagAssignment)+import Distribution.Types.PackageName (unPackageName)+#elif MIN_VERSION_Cabal(2,0,0)+import Distribution.PackageDescription.Configuration (finalizePD)+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec)+import Distribution.Types.PackageName (unPackageName)+#else+import Distribution.Package (PackageName(PackageName))+import Distribution.PackageDescription.Configuration (finalizePackageDescription)+import Distribution.PackageDescription.Parse (readPackageDescription)+#endif++import Control.Exception (throwIO)+import Control.Monad (filterM)+import CoreMonad (liftIO)+import Data.Maybe (maybeToList, mapMaybe)+import Data.Set (fromList, toList)+import System.Directory (doesFileExist)+import System.FilePath (dropExtension, takeFileName, (</>))++import Hhp.Types+import Hhp.GhcPkg++----------------------------------------------------------------++-- | Getting necessary 'CompilerOptions' from three information sources.+getCompilerOptions :: [GHCOption]+                   -> Cradle+                   -> PackageDescription+                   -> IO CompilerOptions+getCompilerOptions ghcopts cradle pkgDesc = do+    gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos+    dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)+    return $ CompilerOptions gopts idirs (depPkgs dbPkgs)+  where+    wdir       = cradleCurrentDir cradle+    rdir       = cradleRootDir    cradle+    Just cfile = cradleCabalFile  cradle+    thisPkg    = dropExtension $ takeFileName cfile+    buildInfos = cabalAllBuildInfo pkgDesc+    idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos+    depPkgs ps = attachPackageIds ps+                   $ removeThem (problematicPackages ++ [thisPkg])+                   $ cabalDependPackages buildInfos++----------------------------------------------------------------+-- Dependent packages++removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]+removeThem badpkgs = filter (`notElem` badpkgs)++problematicPackages :: [PackageBaseName]+problematicPackages = [+    "base-compat" -- providing "Prelude"+  ]++attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]+attachPackageIds pkgs = mapMaybe (`lookup3` pkgs)++lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)+lookup3 _ [] = Nothing+lookup3 k (t@(a,_,_):ls)+    | k == a = Just t+    | otherwise = lookup3 k ls++----------------------------------------------------------------+-- Include directories for modules++cabalBuildDirs :: [FilePath]+cabalBuildDirs = ["dist/build", "dist/build/autogen"]++includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]+includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])+  where+    extdirs = map expand $ dirs ++ cabalBuildDirs+    expand "."    = cdir+    expand subdir = cdir </> subdir++----------------------------------------------------------------++-- | Parsing a cabal file and returns 'PackageDescription'.+--   'IOException' is thrown if parsing fails.+parseCabalFile :: FilePath -> IO PackageDescription+parseCabalFile file = do+    cid <- getGHCId+    let cid' = unknownCompilerInfo cid NoAbiTag+#if MIN_VERSION_Cabal(2,2,0)+    epgd <- readGenericPackageDescription silent file+#else+    epgd <- readPackageDescription silent file+#endif+    case toPkgDesc cid' epgd of+        Left deps    -> throwIO $ userError $ show deps ++ " are not installed"+        Right (pd,_) -> if nullPkg pd+                        then throwIO $ userError $ file ++ " is broken"+                        else return pd+  where+#if MIN_VERSION_Cabal(2,2,0)+    none = mkFlagAssignment []+#else+    none = []+#endif+#if MIN_VERSION_Cabal(2,0,0)+    nullPkg pd = unPackageName (C.pkgName (P.package pd)) == ""+    toPkgDesc cid = finalizePD none defaultComponentRequestedSpec (const True) buildPlatform cid []+#else+    nullPkg pd = name == ""+      where+        PackageName name = C.pkgName (P.package pd)+    toPkgDesc cid = finalizePackageDescription none (const True) buildPlatform cid []+#endif++----------------------------------------------------------------++getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]+getGHCOptions ghcopts cradle rdir binfo = do+    cabalCpp <- cabalCppOptions rdir+    let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp+    return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps+  where+    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle+    lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo+    libDirs = map ("-L" ++) $ P.extraLibDirs binfo+    exts = map (("-X" ++) . display) $ P.usedExtensions binfo+    libs = map ("-l" ++) $ P.extraLibs binfo++cabalCppOptions :: FilePath -> IO [String]+cabalCppOptions dir = do+    exist <- doesFileExist cabalMacro+    return $ if exist then+        ["-include", cabalMacro]+      else+        []+  where+    cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"++----------------------------------------------------------------++-- | Extracting all 'BuildInfo' for libraries, executables, and tests.+cabalAllBuildInfo :: PackageDescription -> [BuildInfo]+cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI+  where+    libBI   = map P.libBuildInfo       $ maybeToList $ P.library pd+    execBI  = map P.buildInfo          $ P.executables pd+    testBI  = map P.testBuildInfo      $ P.testSuites pd+#if __GLASGOW_HASKELL__ >= 704+    benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd+#else+    benchBI = []+#endif++----------------------------------------------------------------++-- | Extracting package names of dependency.+cabalDependPackages :: [BuildInfo] -> [PackageBaseName]+cabalDependPackages bis = uniqueAndSort pkgs+  where+    pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis+#if MIN_VERSION_Cabal(2,0,0)+    getDependencyPackageName (Dependency pkg _) = unPackageName pkg+#else+    getDependencyPackageName (Dependency (PackageName nm) _) = nm+#endif++----------------------------------------------------------------++-- | Extracting include directories for modules.+cabalSourceDirs :: [BuildInfo] -> [IncludeDir]+cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis++----------------------------------------------------------------++uniqueAndSort :: [String] -> [String]+uniqueAndSort = toList . fromList++----------------------------------------------------------------++getGHCId :: IO CompilerId+getGHCId = CompilerId GHC <$> getGHC++getGHC :: IO Version+getGHC = do+    mv <- programFindVersion ghcProgram silent (programName ghcProgram)+    case mv of+        Nothing -> throwIO $ userError "ghc not found"+        Just v  -> return v++----------------------------------------------------------------++-- | Extracting all 'Module' 'FilePath's for libraries, executables,+-- tests and benchmarks.+cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])+cabalAllTargets pd = do+    exeTargets  <- mapM getExecutableTarget $ P.executables pd+    testTargets <- mapM getTestTarget $ P.testSuites pd+    return (libTargets,concat exeTargets,concat testTargets,benchTargets)+  where+    lib = case P.library pd of+            Nothing -> []+#if MIN_VERSION_Cabal(2,0,0)+            Just l -> P.explicitLibModules l+#else+            Just l -> P.libModules l+#endif++    libTargets = map toModuleString lib+#if __GLASGOW_HASKELL__ >= 704+    benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks  pd+#else+    benchTargets = []+#endif+    toModuleString :: ModuleName -> String+    toModuleString mn = fromFilePath $ toFilePath mn++    fromFilePath :: FilePath -> String+    fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp++    getTestTarget :: TestSuite -> IO [String]+    getTestTarget ts =+       case P.testInterface ts of+        (TestSuiteExeV10 _ filePath) -> do+          let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]+          liftIO $ filterM doesFileExist maybeTests+        (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]+        (TestSuiteUnsupported _)       -> return []++    getExecutableTarget :: Executable -> IO [String]+    getExecutableTarget exe = do+      let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]+      liftIO $ filterM doesFileExist maybeExes
+ lib/Hhp/Check.hs view
@@ -0,0 +1,68 @@+module Hhp.Check (+    checkSyntax+  , check+  , expandTemplate+  , expand+  ) where++import DynFlags (dopt_set, DumpFlag(Opt_D_dump_splices))+import GHC (Ghc, DynFlags(..))++import Hhp.GHCApi+import Hhp.Logger+import Hhp.Types++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+checkSyntax :: Options+            -> Cradle+            -> [FilePath]  -- ^ The target files.+            -> IO String+checkSyntax _   _      []    = return ""+checkSyntax opt cradle files = withGHC sessionName $ do+    initializeFlagsWithCradle opt cradle+    either id id <$> check opt files+  where+    sessionName = case files of+      [file] -> file+      _      -> "MultipleFiles"++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+check :: Options+      -> [FilePath]  -- ^ The target files.+      -> Ghc (Either String String)+check opt fileNames = withLogger opt setAllWaringFlags $+    setTargetFiles fileNames++----------------------------------------------------------------++-- | Expanding Haskell Template.+expandTemplate :: Options+               -> Cradle+               -> [FilePath]  -- ^ The target files.+               -> IO String+expandTemplate _   _      []    = return ""+expandTemplate opt cradle files = withGHC sessionName $ do+    initializeFlagsWithCradle opt cradle+    either id id <$> expand opt files+  where+    sessionName = case files of+      [file] -> file+      _      -> "MultipleFiles"++----------------------------------------------------------------++-- | Expanding Haskell Template.+expand :: Options+      -> [FilePath]  -- ^ The target files.+      -> Ghc (Either String String)+expand opt fileNames = withLogger opt (setDumpSplices . setNoWaringFlags) $+    setTargetFiles fileNames++setDumpSplices :: DynFlags -> DynFlags+setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices
+ lib/Hhp/Cradle.hs view
@@ -0,0 +1,106 @@+module Hhp.Cradle (+    findCradle+  , findCradleWithoutSandbox+  ) where++import Control.Applicative ((<|>))+import qualified Control.Exception as E+import Control.Monad (filterM)+import Data.List (isSuffixOf)+import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)+import System.FilePath ((</>), takeDirectory)++import Hhp.Types+import Hhp.GhcPkg++----------------------------------------------------------------++-- | Finding 'Cradle'.+--   Find a cabal file by tracing ancestor directories.+--   Find a sandbox according to a cabal sandbox config+--   in a cabal directory.+findCradle :: IO Cradle+findCradle = do+    wdir <- getCurrentDirectory+    cabalCradle wdir <|> sandboxCradle wdir <|> plainCradle wdir++cabalCradle :: FilePath -> IO Cradle+cabalCradle wdir = do+    (rdir,cfile) <- cabalDir wdir+    pkgDbStack <- getPackageDbStack rdir+    return Cradle {+        cradleCurrentDir = wdir+      , cradleRootDir    = rdir+      , cradleCabalFile  = Just cfile+      , cradlePkgDbStack = pkgDbStack+      }++sandboxCradle :: FilePath -> IO Cradle+sandboxCradle wdir = do+    rdir <- getSandboxDir wdir+    pkgDbStack <- getPackageDbStack rdir+    return Cradle {+        cradleCurrentDir = wdir+      , cradleRootDir    = rdir+      , cradleCabalFile  = Nothing+      , cradlePkgDbStack = pkgDbStack+      }++plainCradle :: FilePath -> IO Cradle+plainCradle wdir = return Cradle {+        cradleCurrentDir = wdir+      , cradleRootDir    = wdir+      , cradleCabalFile  = Nothing+      , cradlePkgDbStack = [GlobalDb]+      }++-- Just for testing+findCradleWithoutSandbox :: IO Cradle+findCradleWithoutSandbox = do+    cradle <- findCradle+    return cradle { cradlePkgDbStack = [GlobalDb]}++----------------------------------------------------------------++cabalSuffix :: String+cabalSuffix = ".cabal"++cabalSuffixLength :: Int+cabalSuffixLength = length cabalSuffix++-- Finding a Cabal file up to the root directory+-- Input: a directly to investigate+-- Output: (the path to the directory containing a Cabal file+--         ,the path to the Cabal file)+cabalDir :: FilePath -> IO (FilePath,FilePath)+cabalDir dir = do+    cnts <- getCabalFiles dir+    case cnts of+        [] | dir' == dir -> E.throwIO $ userError "cabal files not found"+           | otherwise   -> cabalDir dir'+        cfile:_          -> return (dir,dir </> cfile)+  where+    dir' = takeDirectory dir++getCabalFiles :: FilePath -> IO [FilePath]+getCabalFiles dir = getFiles >>= filterM doesCabalFileExist+  where+    isCabal name = cabalSuffix `isSuffixOf` name+                && length name > cabalSuffixLength+    getFiles = filter isCabal <$> getDirectoryContents dir+    doesCabalFileExist file = doesFileExist $ dir </> file++----------------------------------------------------------------++getSandboxDir :: FilePath -> IO FilePath+getSandboxDir dir = do+    exist <- doesFileExist sfile+    if exist then+        return dir+      else if dir == dir' then+        E.throwIO $ userError "sandbox not found"+      else+        getSandboxDir dir'+  where+    sfile = dir </> "cabal.sandbox.config"+    dir' = takeDirectory dir
+ lib/Hhp/Debug.hs view
@@ -0,0 +1,55 @@+module Hhp.Debug (debugInfo, rootInfo) where++import CoreMonad (liftIO)++import Control.Applicative ((<|>))+import Data.List (intercalate)+import Data.Maybe (fromMaybe, isJust, fromJust)++import Hhp.CabalApi+import Hhp.GHCApi+import Hhp.Types++----------------------------------------------------------------++-- | Obtaining debug information.+debugInfo :: Options+          -> Cradle+          -> IO String+debugInfo opt cradle = convert opt <$> do+    CompilerOptions gopts incDir pkgs <-+        if cabal then+            liftIO (fromCabalFile <|> return simpleCompilerOption)+          else+            return simpleCompilerOption+    mglibdir <- liftIO getSystemLibDir+    return [+        "Root directory:      " ++ rootDir+      , "Current directory:   " ++ currentDir+      , "Cabal file:          " ++ cabalFile+      , "GHC options:         " ++ unwords gopts+      , "Include directories: " ++ unwords incDir+      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)+      , "System libraries:    " ++ fromMaybe "" mglibdir+      ]+  where+    currentDir = cradleCurrentDir cradle+    mCabalFile = cradleCabalFile cradle+    rootDir    = cradleRootDir cradle+    cabal = isJust mCabalFile+    cabalFile = fromMaybe "" mCabalFile+    origGopts = ghcOpts opt+    simpleCompilerOption = CompilerOptions origGopts [] []+    fromCabalFile = do+        pkgDesc <- parseCabalFile file+        getCompilerOptions origGopts cradle pkgDesc+      where+        file = fromJust mCabalFile++----------------------------------------------------------------++-- | Obtaining root information.+rootInfo :: Options+          -> Cradle+          -> IO String+rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
+ lib/Hhp/Doc.hs view
@@ -0,0 +1,24 @@+module Hhp.Doc where++import GHC (Ghc, DynFlags, getPrintUnqual, pprCols)+import Outputable (PprStyle, SDoc, withPprStyleDoc, neverQualify)+import Pretty (Mode(..), Doc, Style(..), renderStyle, style)++import Hhp.Gap (makeUserStyle)++showPage :: DynFlags -> PprStyle -> SDoc -> String+showPage dflag stl = showDocWith dflag PageMode . withPprStyleDoc dflag stl++showOneLine :: DynFlags -> PprStyle -> SDoc -> String+showOneLine dflag stl = showDocWith dflag OneLineMode . withPprStyleDoc dflag stl++getStyle :: DynFlags -> Ghc PprStyle+getStyle dflags = makeUserStyle dflags <$> getPrintUnqual++styleUnqualified :: DynFlags -> PprStyle+styleUnqualified dflags = makeUserStyle dflags neverQualify++showDocWith :: DynFlags -> Mode -> Doc -> String+showDocWith dflags md = renderStyle mstyle+  where+    mstyle = style { mode = md, lineLength = pprCols dflags }
+ lib/Hhp/Find.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}++module Hhp.Find (+    Symbol+  , SymMdlDb+  , findSymbol+  , getSymMdlDb+  , lookupSym+  ) where++import GHC (Ghc, DynFlags, Module, ModuleInfo)+import qualified GHC as G+import Module (Module(..))+import Outputable (ppr)+import PackageConfig (PackageConfig, exposedModules, packageConfigId)+import Packages (listPackageConfigMap)++import Control.DeepSeq (force)+import Data.Function (on)+import Data.List (groupBy, sort)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)++import Hhp.Doc (showOneLine, styleUnqualified)+import Hhp.GHCApi+import Hhp.Gap (getModuleName)+import Hhp.Types++-- | Type of key for `SymMdlDb`.+type Symbol = String+-- | Database from 'Symbol' to modules.+newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])++-- | Finding modules to which the symbol belong.+findSymbol :: Options -> Cradle -> Symbol -> IO String+findSymbol opt cradle sym = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    lookupSym opt sym <$> getSymMdlDb++-- | Creating 'SymMdlDb'.+getSymMdlDb :: Ghc SymMdlDb+getSymMdlDb = do+    sm <- G.getSessionDynFlags >>= browseAll+    let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm+        !m = force $ M.fromList sms+    return (SymMdlDb m)+  where+    tieup x = (head (map fst x), map snd x)++-- | Looking up 'SymMdlDb' with 'Symbol' to find modules.+lookupSym :: Options -> Symbol -> SymMdlDb -> String+lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db)++----------------------------------------------------------------++-- | Browsing all functions in all system/user modules.+browseAll :: DynFlags -> Ghc [(String,String)]+browseAll dflag = do+    let ms = packageModules dflag+    is <- mapM G.getModuleInfo ms+    return $ concatMap (toNameModule dflag) (zip ms is)++toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)]+toNameModule _     (_,Nothing)  = []+toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names+  where+    mdl = G.moduleNameString (G.moduleName m)+    names = G.modInfoExports inf+    toStr = showOneLine dflag (styleUnqualified dflag) . ppr++packageModules :: DynFlags -> [Module]+packageModules dflag = concatMap fromPackageConfig $ listPackageConfigMap dflag++fromPackageConfig :: PackageConfig -> [Module]+fromPackageConfig pkgcnf = modules+  where+    uid = packageConfigId pkgcnf -- check me+    moduleNames = map getModuleName $ exposedModules pkgcnf+    modules = map (Module uid) moduleNames
+ lib/Hhp/Flag.hs view
@@ -0,0 +1,18 @@+module Hhp.Flag where++import DynFlags++import Hhp.Types++-- | Listing GHC flags. (e.g -Wno-orphans)++listFlags :: Options -> IO String+listFlags opt = return $ convert opt options+  where+    options = expand "-f" fOptions ++ expand "-W" wOptions+    fOptions = map flagSpecName fFlags ++ map flagSpecName fLangFlags+    wOptions = map flagSpecName wWarningFlags+    expand prefix lst = [ prefix ++ no ++ option+                        | option <- lst+                        , no <- ["","no-"]+                        ]
+ lib/Hhp/GHCApi.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}++module Hhp.GHCApi (+    withGHC+  , withGHC'+  , initializeFlagsWithCradle+  , setTargetFiles+  , getDynamicFlags+  , getSystemLibDir+  , withDynFlags+  , withCmdFlags+  , setNoWaringFlags+  , setAllWaringFlags+  ) where++import CoreMonad (liftIO)+import DynFlags (GeneralFlag(Opt_BuildingCabalPackage, Opt_HideAllPackages), gopt_set, ModRenaming(..), PackageFlag(ExposePackage), PackageArg(..))+import Exception (ghandle, SomeException(..))+import GHC (Ghc, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))+import qualified GHC as G++import Control.Applicative ((<|>))+import Control.Monad (forM, void)+import Data.Maybe (isJust, fromJust)+import System.Exit (exitSuccess)+import System.IO (hPutStr, hPrint, stderr)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (readProcess)++import Hhp.CabalApi+import qualified Hhp.Gap as Gap+import Hhp.GhcPkg+import Hhp.Types++----------------------------------------------------------------++-- | Obtaining the directory for system libraries.+getSystemLibDir :: IO (Maybe FilePath)+getSystemLibDir = do+    res <- readProcess "ghc" ["--print-libdir"] []+    return $ case res of+        ""   -> Nothing+        dirn -> Just (init dirn)++----------------------------------------------------------------++-- | Converting the 'Ghc' monad to the 'IO' monad.+withGHC :: FilePath  -- ^ A target file displayed in an error message.+        -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.+        -> IO a+withGHC file body = ghandle ignore $ withGHC' body+  where+    ignore :: SomeException -> IO a+    ignore e = do+        hPutStr stderr $ file ++ ":0:0:Error:"+        hPrint stderr e+        exitSuccess++withGHC' :: Ghc a -> IO a+withGHC' body = do+    mlibdir <- getSystemLibDir+    G.runGhc mlibdir body++----------------------------------------------------------------++importDirs :: [IncludeDir]+importDirs = [".","..","../..","../../..","../../../..","../../../../.."]++data Build = CabalPkg | SingleFile deriving Eq++-- | Initialize the 'DynFlags' relating to the compilation of a single+-- file or GHC session according to the 'Cradle' and 'Options'+-- provided.+initializeFlagsWithCradle ::+           Options+        -> Cradle+        -> Ghc ()+initializeFlagsWithCradle opt cradle+  | cabal     = withCabal <|> withSandbox+  | otherwise = withSandbox+  where+    mCradleFile = cradleCabalFile cradle+    cabal = isJust mCradleFile+    ghcopts = ghcOpts opt+    withCabal = do+        pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile+        compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc+        initSession CabalPkg opt compOpts+    withSandbox = initSession SingleFile opt compOpts+      where+        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle+        compOpts+          | null pkgOpts = CompilerOptions ghcopts importDirs []+          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []+        wdir = cradleCurrentDir cradle+        rdir = cradleRootDir    cradle++----------------------------------------------------------------++initSession :: Build+            -> Options+            -> CompilerOptions+            -> Ghc ()+initSession build Options {..} CompilerOptions {..} = do+    df <- G.getSessionDynFlags+    void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions+      $ setLinkerOptions+      $ setIncludeDirs includeDirs+      $ setBuildEnv build+      $ setEmptyLogger+      $ addPackageFlags depPackages df)++setEmptyLogger :: DynFlags -> DynFlags+setEmptyLogger df = df { G.log_action =  \_ _ _ _ _ _ -> return () }++----------------------------------------------------------------++-- we don't want to generate object code so we compile to bytecode+-- (HscInterpreted) which implies LinkInMemory+-- HscInterpreted+setLinkerOptions :: DynFlags -> DynFlags+setLinkerOptions df = df {+    ghcLink   = LinkInMemory+  , hscTarget = HscInterpreted+  }++setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags+setIncludeDirs idirs df = df { importPaths = idirs }++setBuildEnv :: Build -> DynFlags -> DynFlags+setBuildEnv build = setHideAllPackages build . setCabalPackage build++-- At the moment with this option set ghc only prints different error messages,+-- suggesting the user to add a hidden package to the build-depends in his cabal+-- file for example+setCabalPackage :: Build -> DynFlags -> DynFlags+setCabalPackage CabalPkg df = setCabalPkg df+setCabalPackage _ df = df++-- | Enable hiding of all package not explicitly exposed (like Cabal does)+setHideAllPackages :: Build -> DynFlags -> DynFlags+setHideAllPackages CabalPkg df = gopt_set df Opt_HideAllPackages+setHideAllPackages _ df        = df++-- | Parse command line ghc options and add them to the 'DynFlags' passed+addCmdOpts :: [GHCOption] -> DynFlags -> Ghc DynFlags+addCmdOpts cmdOpts df =+    tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)+  where+    tfst (a,_,_) = a++----------------------------------------------------------------++-- | Set the files as targets and load them.+setTargetFiles :: [FilePath] -> Ghc ()+setTargetFiles files = do+    targets <- forM files $ \file -> G.guessTarget file Nothing+    G.setTargets targets+    void $ G.load LoadAllTargets++----------------------------------------------------------------++-- | Return the 'DynFlags' currently in use in the GHC session.+getDynamicFlags :: IO DynFlags+getDynamicFlags = do+    mlibdir <- getSystemLibDir+    G.runGhc mlibdir G.getSessionDynFlags++withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a+withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflag <- G.getSessionDynFlags+        void $ G.setSessionDynFlags (setFlag dflag)+        return dflag+    teardown = void . G.setSessionDynFlags++withCmdFlags :: [GHCOption] -> Ghc a -> Ghc a+withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflag <- G.getSessionDynFlags >>= addCmdOpts flags+        void $ G.setSessionDynFlags dflag+        return dflag+    teardown = void . G.setSessionDynFlags++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-w:".+setNoWaringFlags :: DynFlags -> DynFlags+setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags}++-- | Set 'DynFlags' equivalent to "-Wall".+setAllWaringFlags :: DynFlags -> DynFlags+setAllWaringFlags df = df { warningFlags = allWarningFlags }++{-# NOINLINE allWarningFlags #-}+allWarningFlags :: Gap.WarnFlags+allWarningFlags = unsafePerformIO $ do+    mlibdir <- getSystemLibDir+    G.runGhc mlibdir $ do+        df <- G.getSessionDynFlags+        df' <- addCmdOpts ["-Wall"] df+        return $ G.warningFlags df'++setCabalPkg :: DynFlags -> DynFlags+setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage++addPackageFlags :: [Package] -> DynFlags -> DynFlags+addPackageFlags pkgs df =+    df { packageFlags = packageFlags df ++ expose `map` pkgs }+  where+    expose pkg = ExposePackage pkgid (PackageArg name) (ModRenaming True [])+      where+        (name,_,_) = pkg+        pkgid = showPkgId pkg
+ lib/Hhp/Gap.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}++module Hhp.Gap (+    WarnFlags+  , emptyWarnFlags+  , makeUserStyle+  , getModuleName+  , getTyThing+  , fixInfo+  , getModSummaries+  , LExpression+  , LBinding+  , LPattern+  , inTypes+  , outType+  ) where++import DynFlags (DynFlags)+import GHC(LHsBind, LHsExpr, LPat, Type)+import HsExpr (MatchGroup)+import Outputable (PrintUnqualified, PprStyle, Depth(AllTheWay), mkUserStyle)++----------------------------------------------------------------+----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 802+#else+import GHC.PackageDb (ExposedModule(..))+#endif++#if __GLASGOW_HASKELL__ >= 804+import DynFlags (WarningFlag)+import qualified EnumSet as E (EnumSet, empty)+import GHC (mgModSummaries, ModSummary, ModuleGraph)+#else+import qualified Data.IntSet as I (IntSet, empty)+#endif++#if __GLASGOW_HASKELL__ >= 806+import HsExpr (MatchGroupTc(..))+import HsExtension (GhcTc)+import GHC (mg_ext)+#elif __GLASGOW_HASKELL__ >= 804+import HsExtension (GhcTc)+import GHC (mg_res_ty, mg_arg_tys)+#else+import GHC (Id, mg_res_ty, mg_arg_tys)+#endif++----------------------------------------------------------------+----------------------------------------------------------------++makeUserStyle :: DynFlags -> PrintUnqualified -> PprStyle+#if __GLASGOW_HASKELL__ >= 802+makeUserStyle dflags style = mkUserStyle dflags style AllTheWay+#else+makeUserStyle _      style = mkUserStyle        style AllTheWay+#endif++#if __GLASGOW_HASKELL__ >= 802+getModuleName :: (a, b) -> a+getModuleName = fst+#else+getModuleName :: ExposedModule unitid modulename -> modulename+getModuleName = exposedName+#endif++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 804+type WarnFlags = E.EnumSet WarningFlag+emptyWarnFlags :: WarnFlags+emptyWarnFlags = E.empty+#else+type WarnFlags = I.IntSet+emptyWarnFlags :: WarnFlags+emptyWarnFlags = I.empty+#endif++#if __GLASGOW_HASKELL__ >= 804+getModSummaries :: ModuleGraph -> [ModSummary]+getModSummaries = mgModSummaries++getTyThing :: (a, b, c, d, e) -> a+getTyThing (t,_,_,_,_) = t++fixInfo :: (a, b, c, d, e) -> (a, b, c, d)+fixInfo (t,f,cs,fs,_) = (t,f,cs,fs)+#else+getModSummaries :: a -> a+getModSummaries = id++getTyThing :: (a, b, c, d) -> a+getTyThing (t,_,_,_) = t++fixInfo :: (a, b, c, d) -> (a, b, c, d)+fixInfo = id+#endif++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 806+type LExpression = LHsExpr GhcTc+type LBinding    = LHsBind GhcTc+type LPattern    = LPat    GhcTc++inTypes :: MatchGroup GhcTc LExpression -> [Type]+inTypes = mg_arg_tys . mg_ext+outType :: MatchGroup GhcTc LExpression -> Type+outType = mg_res_ty . mg_ext+#elif __GLASGOW_HASKELL__ >= 804+type LExpression = LHsExpr GhcTc+type LBinding    = LHsBind GhcTc+type LPattern    = LPat    GhcTc++inTypes :: MatchGroup GhcTc LExpression -> [Type]+inTypes = mg_arg_tys+outType :: MatchGroup GhcTc LExpression -> Type+outType = mg_res_ty+#else+type LExpression = LHsExpr Id+type LBinding    = LHsBind Id+type LPattern    = LPat    Id++inTypes :: MatchGroup Id LExpression -> [Type]+inTypes = mg_arg_tys+outType :: MatchGroup Id LExpression -> Type+outType = mg_res_ty+#endif
+ lib/Hhp/Ghc.hs view
@@ -0,0 +1,32 @@+-- | The Happy Haskell Programming library.+--   API for interactive processes++module Hhp.Ghc (+  -- * Converting the Ghc monad to the IO monad+    withGHC+  , withGHC'+  -- * Initializing DynFlags+  , initializeFlagsWithCradle+  -- * Ghc utilities+  , boot+  , browse+  , check+  , info+  , types+  , modules+  -- * SymMdlDb+  , Symbol+  , SymMdlDb+  , getSymMdlDb+  , lookupSym+  -- * Misc+  , getSystemLibDir+  ) where++import Hhp.Boot+import Hhp.Browse+import Hhp.Check+import Hhp.Find+import Hhp.GHCApi+import Hhp.Info+import Hhp.List
+ lib/Hhp/GhcPkg.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}+module Hhp.GhcPkg (+    ghcPkgList+  , ghcPkgListEx+  , ghcPkgDbOpt+  , ghcPkgDbStackOpts+  , ghcDbStackOpts+  , ghcDbOpt+  , getSandboxDb+  , getPackageDbStack+  ) where++import Config (cProjectVersionInt) -- ghc version++import Control.Exception (SomeException(..))+import qualified Control.Exception as E+import Data.Char (isSpace,isAlphaNum)+import Data.List (isPrefixOf, intercalate, dropWhileEnd)+import Data.Maybe (listToMaybe, maybeToList)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO (hPutStrLn,stderr)+import System.Process (readProcessWithExitCode)+import Text.ParserCombinators.ReadP (ReadP, char, between, sepBy1, many1, string, choice, eof)+import qualified Text.ParserCombinators.ReadP as P++import Hhp.Types++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++-- | Get path to sandbox package db+getSandboxDb :: FilePath -- ^ Path to the cabal package root directory+                         -- (containing the @cabal.sandbox.config@ file)+             -> IO FilePath+getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")++-- | Extract the sandbox package db directory from the cabal.sandbox.config file.+--   Exception is thrown if the sandbox config file is broken.+getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file+                -> IO FilePath+getSandboxDbDir sconf = do+    -- Be strict to ensure that an error can be caught.+    !path <- extractValue . parse <$> readFile sconf+    return path+  where+    key = "package-db:"+    keyLen = length key++    parse = head . filter (key `isPrefixOf`) . lines+    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen++getPackageDbStack :: FilePath -- ^ Project Directory (where the+                                 -- cabal.sandbox.config file would be if it+                                 -- exists)+                  -> IO [GhcPkgDb]+getPackageDbStack cdir =+    (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])+      `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]+++-- | List packages in one or more ghc package store+ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]+ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs+  where fst3 (x,_,_) = x++ghcPkgListEx :: [GhcPkgDb] -> IO [Package]+ghcPkgListEx dbs = do+    (rv,output,err) <- readProcessWithExitCode "ghc-pkg" opts ""+    case rv of+      ExitFailure val -> do+          hPutStrLn stderr err+          fail $ "ghc-pkg " ++ unwords opts ++ " (exit " ++ show val ++ ")"+      ExitSuccess -> return ()++    return $ parseGhcPkgOutput $ lines output+  where+    opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs++parseGhcPkgOutput :: [String] -> [Package]+parseGhcPkgOutput [] = []+parseGhcPkgOutput (l:ls) =+    parseGhcPkgOutput ls ++ case l of+      [] -> []+      h:_ | isSpace h -> maybeToList $ packageLine l+          | otherwise -> []++packageLine :: String -> Maybe Package+packageLine l =+    case listToMaybe $ P.readP_to_S packageLineP l of+      Just ((Normal,p),_) -> Just p+      Just ((Hidden,p),_) -> Just p+      _ -> Nothing++data PackageState = Normal | Hidden | Broken deriving (Eq,Show)++packageLineP :: ReadP (PackageState, Package)+packageLineP = do+    P.skipSpaces+    p <- choice [ (Hidden,) <$> between (char '(') (char ')') packageP+                , (Broken,) <$> between (char '{') (char '}') packageP+                , (Normal,) <$> packageP ]+    eof+    return p++packageP :: ReadP (PackageBaseName, PackageVersion, PackageId)+packageP = do+    pkgSpec@(name,ver) <- packageSpecP+    P.skipSpaces+    i <- between (char '(') (char ')') $ packageIdSpecP pkgSpec+    return (name,ver,i)++packageSpecP :: ReadP (PackageBaseName,PackageVersion)+packageSpecP = do+  fs <- many1 packageCompCharP `sepBy1` char '-'+  return (intercalate "-" (init fs), last fs)++packageIdSpecP :: (PackageBaseName,PackageVersion) -> ReadP PackageId+packageIdSpecP (name,ver) = do+    _ <- string name >> char '-' >> string ver+    choice [ char '-' >> many1 (P.satisfy isAlphaNum)+           , return ""]++packageCompCharP :: ReadP Char+packageCompCharP =+    P.satisfy $ \c -> isAlphaNum c || c `elem` "_-."++-- | Get options needed to add a list of package dbs to ghc-pkg's db stack+ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+                  -> [String]+ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs++-- | Get options needed to add a list of package dbs to ghc's db stack+ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+               -> [String]+ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs++ghcPkgDbOpt :: GhcPkgDb -> [String]+ghcPkgDbOpt GlobalDb = ["--global"]+ghcPkgDbOpt UserDb   = ["--user"]+ghcPkgDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]+  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]++ghcDbOpt :: GhcPkgDb -> [String]+ghcDbOpt GlobalDb+  | ghcVersion < 706 = ["-global-package-conf"]+  | otherwise        = ["-global-package-db"]+ghcDbOpt UserDb+  | ghcVersion < 706 = ["-user-package-conf"]+  | otherwise        = ["-user-package-db"]+ghcDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]+  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]
+ lib/Hhp/Info.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}++module Hhp.Info (+    infoExpr+  , info+  , typeExpr+  , types+  ) where++import CoreMonad (liftIO)+import CoreUtils (exprType)+import Desugar (deSugarExpr)+import DynFlags (gopt_set, wopt_set, WarningFlag(Opt_WarnTypedHoles))+import Exception (ghandle, SomeException(..))+import GHC (Ghc, TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))+import qualified GHC as G+import HsBinds (HsBindLR(..))+import HscTypes (ModSummary)+import Outputable (PprStyle)+import PprTyThing+import TcHsSyn (hsPatType)+import TcType (mkFunTys)++import Control.Applicative ((<|>))+import Control.Monad (filterM)+import Data.Function (on)+import Data.List (sortBy)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Ord as O++import Hhp.Doc (showPage, showOneLine, getStyle)+import Hhp.GHCApi+import Hhp.Gap+import Hhp.Logger (getSrcSpan)+import Hhp.Syb+import Hhp.Things+import Hhp.Types++----------------------------------------------------------------++-- | Obtaining information of a target expression. (GHCi's info:)+infoExpr :: Options+         -> Cradle+         -> FilePath     -- ^ A target file.+         -> Expression   -- ^ A Haskell expression.+         -> IO String+infoExpr opt cradle file expr = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    info opt file expr++-- | Obtaining information of a target expression. (GHCi's info:)+info :: Options+     -> FilePath     -- ^ A target file.+     -> Expression   -- ^ A Haskell expression.+     -> Ghc String+info opt file expr = convert opt <$> ghandle handler body+  where+    body = inModuleContext file $ \dflag style -> do+        sdoc <- infoThing expr+        return $ showPage dflag style sdoc+    handler (SomeException _) = return "Cannot show info"++----------------------------------------------------------------++-- | Obtaining type of a target expression. (GHCi's type:)+typeExpr :: Options+         -> Cradle+         -> FilePath     -- ^ A target file.+         -> Int          -- ^ Line number.+         -> Int          -- ^ Column number.+         -> IO String+typeExpr opt cradle file lineNo colNo = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    types opt file lineNo colNo++-- | Obtaining type of a target expression. (GHCi's type:)+types :: Options+      -> FilePath     -- ^ A target file.+      -> Int          -- ^ Line number.+      -> Int          -- ^ Column number.+      -> Ghc String+types opt file lineNo colNo = convert opt <$> ghandle handler body+  where+    body = inModuleContext file $ \dflag style -> do+        modSum <- fileModSummary file+        srcSpanTypes <- getSrcSpanType modSum lineNo colNo+        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes+    handler (SomeException _) = return []++getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]+getSrcSpanType modSum lineNo colNo = do+    p <- G.parseModule modSum+    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+    let es = listifySpans tcs (lineNo, colNo) :: [LExpression]+        bs = listifySpans tcs (lineNo, colNo) :: [LBinding]+        ps = listifySpans tcs (lineNo, colNo) :: [LPattern]+    ets <- mapM (getType tcm) es+    bts <- mapM (getType tcm) bs+    pts <- mapM (getType tcm) ps+    return $ catMaybes $ concat [ets, bts, pts]++cmp :: SrcSpan -> SrcSpan -> Ordering+cmp a b+  | a `G.isSubspanOf` b = O.LT+  | b `G.isSubspanOf` a = O.GT+  | otherwise           = O.EQ++toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)++fourInts :: SrcSpan -> (Int,Int,Int,Int)+fourInts = fromMaybe (0,0,0,0) . getSrcSpan++pretty :: DynFlags -> PprStyle -> Type -> String+pretty dflag style = showOneLine dflag style . pprTypeForUser++----------------------------------------------------------------++inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a+inModuleContext file action =+    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do+    setTargetFiles [file]+    withContext $ do+        dflag <- G.getSessionDynFlags+        style <- getStyle dflag+        action dflag style++setDeferTypeErrors :: DynFlags -> DynFlags+setDeferTypeErrors dflag = gopt_set dflag G.Opt_DeferTypeErrors++setWarnTypedHoles :: DynFlags -> DynFlags+setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles++----------------------------------------------------------------++fileModSummary :: FilePath -> Ghc ModSummary+fileModSummary file = do+    mss <- getModSummaries <$> G.getModuleGraph+    let [ms] = filter (\m -> G.ml_hs_file (G.ms_location m) == Just file) mss+    return ms++withContext :: Ghc a -> Ghc a+withContext action = G.gbracket setup teardown body+  where+    setup = G.getContext+    teardown = setCtx+    body _ = do+        topImports >>= setCtx+        action+    topImports = do+        mss <- getModSummaries <$> G.getModuleGraph+        map modName <$> filterM isTop mss+    isTop mos = lookupMod mos <|> returnFalse+    lookupMod mos = G.lookupModule (G.ms_mod_name mos) Nothing >> return True+    returnFalse = return False+    modName = G.IIModule . G.moduleName . G.ms_mod+    setCtx = G.setContext++----------------------------------------------------------------++class HasType a where+    getType :: TypecheckedModule -> a -> Ghc (Maybe (SrcSpan, Type))++instance HasType LExpression where+    getType _ e = do+        hs_env <- G.getSession+        mbe <- liftIO $ snd <$> deSugarExpr hs_env e+        return $ (G.getLoc e, ) . CoreUtils.exprType <$> mbe++instance HasType LBinding where+    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)+      where+        in_tys  = inTypes m+        out_typ = outType m+        typ = mkFunTys in_tys out_typ+    getType _ _ = return Nothing++instance HasType LPattern where+    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
+ lib/Hhp/Internal.hs view
@@ -0,0 +1,32 @@+-- | The Happy Haskell Programming library in low level.++module Hhp.Internal (+  -- * Types+    GHCOption+  , Package+  , PackageBaseName+  , PackageVersion+  , PackageId+  , IncludeDir+  , CompilerOptions(..)+  -- * Cabal API+  , parseCabalFile+  , getCompilerOptions+  , cabalAllBuildInfo+  , cabalDependPackages+  , cabalSourceDirs+  , cabalAllTargets+  -- * IO+  , getDynamicFlags+  -- * Targets+  , setTargetFiles+  -- * Logging+  , withLogger+  , setNoWaringFlags+  , setAllWaringFlags+  ) where++import Hhp.CabalApi+import Hhp.GHCApi+import Hhp.Logger+import Hhp.Types
+ lib/Hhp/Lang.hs view
@@ -0,0 +1,10 @@+module Hhp.Lang where++import DynFlags (supportedLanguagesAndExtensions)++import Hhp.Types++-- | Listing language extensions.++listLanguages :: Options -> IO String+listLanguages opt = return $ convert opt supportedLanguagesAndExtensions
+ lib/Hhp/Lint.hs view
@@ -0,0 +1,18 @@+module Hhp.Lint where++import Control.Exception (handle, SomeException(..))+import Language.Haskell.HLint (hlint)++import Hhp.Logger (checkErrorPrefix)+import Hhp.Types++-- | Checking syntax of a target file using hlint.+--   Warnings and errors are returned.+lintSyntax :: Options+           -> FilePath  -- ^ A target file.+           -> IO String+lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)+  where+    pack = convert opt . map (init . show) -- init drops the last \n.+    hopts = hlintOpts opt+    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
+ lib/Hhp/List.hs view
@@ -0,0 +1,37 @@+module Hhp.List (listModules, modules) where++import DynFlags (DynFlags)+import GHC (Ghc)+import qualified GHC as G+import Module (moduleNameString, moduleName)+import Packages (lookupModuleInAllPackages, listVisibleModuleNames)++import Control.Exception (SomeException(..))+import Data.List (nub, sort)++import Hhp.GHCApi+import Hhp.Types++----------------------------------------------------------------++-- | Listing installed modules.+listModules :: Options -> Cradle -> IO String+listModules opt cradle = withGHC' $ do+    initializeFlagsWithCradle opt cradle+    modules opt++-- | Listing installed modules.+modules :: Options -> Ghc String+modules opt = convert opt . arrange <$> (getModules `G.gcatch` handler)+  where+    getModules = listVisibleModules <$> G.getSessionDynFlags+    arrange = nub . sort . map (moduleNameString . moduleName)+    handler (SomeException _) = return []++----------------------------------------------------------------++listVisibleModules :: DynFlags -> [G.Module]+listVisibleModules df = mods+  where+    modNames = listVisibleModuleNames df+    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
+ lib/Hhp/Logger.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}++module Hhp.Logger (+    withLogger+  , checkErrorPrefix+  , getSrcSpan+  ) where++import Bag (Bag, bagToList)+import CoreMonad (liftIO)+import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices))+import ErrUtils+import Exception (ghandle)+import FastString (unpackFS)+import GHC (Ghc, DynFlags(..), SrcSpan(..), Severity(SevError))+import qualified GHC as G+import HscTypes (SourceError, srcErrorMessages)+import Outputable (PprStyle, SDoc)++import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe)+import System.FilePath (normalise)++import Hhp.Doc (showPage, getStyle)+import Hhp.GHCApi (withDynFlags, withCmdFlags)+import Hhp.Types (Options(..), convert)++----------------------------------------------------------------++type Builder = [String] -> [String]++newtype LogRef = LogRef (IORef Builder)++newLogRef :: IO LogRef+newLogRef = LogRef <$> newIORef id++readAndClearLogRef :: Options -> LogRef -> IO String+readAndClearLogRef opt (LogRef ref) = do+    b <- readIORef ref+    writeIORef ref id+    return $! convert opt (b [])++appendLogRef :: DynFlags -> LogRef -> LogAction+appendLogRef df (LogRef ref) _ _ sev src style msg = do+        let !l = ppMsg src sev df style msg+        modifyIORef ref (\b -> b . (l:))++----------------------------------------------------------------++-- | Set the session flag (e.g. "-Wall" or "-w:") then+--   executes a body. Log messages are returned as 'String'.+--   Right is success and Left is failure.+withLogger :: Options -> (DynFlags -> DynFlags) -> Ghc () -> Ghc (Either String String)+withLogger opt setDF body = ghandle (sourceError opt) $ do+    logref <- liftIO newLogRef+    withDynFlags (setLogger logref . setDF) $ do+        withCmdFlags wflags $ do+            body+            liftIO $ Right <$> readAndClearLogRef opt logref+  where+    setLogger logref df = df { log_action =  appendLogRef df logref }+    wflags = filter ("-fno-warn" `isPrefixOf`) $ ghcOpts opt++----------------------------------------------------------------++-- | Converting 'SourceError' to 'String'.+sourceError :: Options -> SourceError -> Ghc (Either String String)+sourceError opt err = do+    dflag <- G.getSessionDynFlags+    style <- getStyle dflag+    let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err+    return (Left ret)++errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]+errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList++----------------------------------------------------------------++ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String+ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext+   where+     spn = errMsgSpan err+     msg = pprLocErrMsg err+     -- fixme+--     ext = showPage dflag style (pprLocErrMsg $ errMsgReason err)++ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String+ppMsg spn sev dflag style msg = prefix ++ cts+  where+    cts  = showPage dflag style msg+    defaultPrefix+      | isDumpSplices dflag = ""+      | otherwise           = checkErrorPrefix+    prefix = fromMaybe defaultPrefix $ do+        (line,col,_,_) <- getSrcSpan spn+        file <- normalise <$> getSrcFile spn+        let severityCaption = showSeverityCaption sev+        return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption++checkErrorPrefix :: String+checkErrorPrefix = "Dummy:0:0:Error:"++showSeverityCaption :: Severity -> String+showSeverityCaption SevWarning = "Warning: "+showSeverityCaption _          = ""++getSrcFile :: SrcSpan -> Maybe String+getSrcFile (G.RealSrcSpan spn) = Just . unpackFS . G.srcSpanFile $ spn+getSrcFile _                   = Nothing++isDumpSplices :: DynFlags -> Bool+isDumpSplices dflag = dopt Opt_D_dump_splices dflag++getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)+getSrcSpan (RealSrcSpan spn) = Just ( G.srcSpanStartLine spn+                                    , G.srcSpanStartCol spn+                                    , G.srcSpanEndLine spn+                                    , G.srcSpanEndCol spn)+getSrcSpan _ = Nothing
+ lib/Hhp/PkgDoc.hs view
@@ -0,0 +1,29 @@+module Hhp.PkgDoc (packageDoc) where++import System.Process (readProcess)++import Hhp.Types+import Hhp.GhcPkg++-- | Obtaining the package name and the doc path of a module.+packageDoc :: Options+           -> Cradle+           -> ModuleString+           -> IO String+packageDoc _ cradle mdl = pkgDoc cradle mdl++pkgDoc :: Cradle -> String -> IO String+pkgDoc cradle mdl = do+    pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []+    if pkg == "" then+        return "\n"+      else do+        htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []+        let ret = pkg ++ " " ++ drop 14 htmlpath+        return ret+  where+    toModuleOpts = ["find-module", mdl, "--simple-output"]+                   ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)+    toDocDirOpts pkg = ["field", pkg, "haddock-html"]+                       ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)+    trim = takeWhile (`notElem` " \n")
+ lib/Hhp/Syb.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE RankNTypes #-}++module Hhp.Syb (+    listifySpans+  ) where++import GHC (TypecheckedSource, Located, GenLocated(L), isGoodSrcSpan, spans)++import Data.Generics++listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]+listifySpans tcs lc = everything' (++) ([] `mkQ` (\x -> [x | p x])) tcs+  where+    p (L spn _) = isGoodSrcSpan spn && spn `spans` lc++everything' :: (r -> r -> r) -> GenericQ r -> GenericQ r+everything' k f x = foldl k (f x) $ gmapQ (everything' k f) x
+ lib/Hhp/Things.hs view
@@ -0,0 +1,63 @@+module Hhp.Things (+    GapThing(..)+  , fromTyThing+  , infoThing+  ) where++import ConLike (ConLike(..))+import FamInstEnv+import GHC+import HscTypes+import qualified InstEnv+import NameSet+import Outputable+import PatSyn+import PprTyThing+import Var (varType)++import Data.List (intersperse)+import Data.Maybe (catMaybes)++import Hhp.Gap (getTyThing, fixInfo)++-- from ghc/InteractiveUI.hs++----------------------------------------------------------------++data GapThing = GtA Type+              | GtT TyCon+              | GtN+              | GtPatSyn PatSyn++fromTyThing :: TyThing -> GapThing+fromTyThing (AnId i)                   = GtA $ varType i+fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d+fromTyThing (AConLike (PatSynCon p))   = GtPatSyn p+fromTyThing (ATyCon t)                 = GtT t+fromTyThing _                          = GtN++----------------------------------------------------------------++infoThing :: String -> Ghc SDoc+infoThing str = do+    names <- parseName str+    mb_stuffs <- mapM (getInfo False) names+    let filtered = filterOutChildren getTyThing $ catMaybes mb_stuffs+    return $ vcat (intersperse (text "") $ map (pprInfo . fixInfo) filtered)++filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+  where+    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [FamInst]) -> SDoc+pprInfo (thing, fixity, insts, famInsts)+    = pprTyThingInContextLoc thing+   $$ show_fixity fixity+   $$ InstEnv.pprInstances insts+   $$ pprFamInsts famInsts+  where+    show_fixity fx+      | fx == defaultFixity = Outputable.empty+      | otherwise           = ppr fx <+> ppr (getName thing)
+ lib/Hhp/Types.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Hhp.Types where++import qualified Exception as GE+import GHC (Ghc)++import Control.Exception (IOException)+import Control.Applicative (Alternative(..))+import Data.List (intercalate)++-- | Output style.+data OutputStyle = LispStyle  -- ^ S expression style.+                 | PlainStyle -- ^ Plain textstyle.++-- | The type for line separator. Historically, a Null string is used.+newtype LineSeparator = LineSeparator String++data Options = Options {+    outputStyle   :: OutputStyle+  , hlintOpts     :: [String]+  , ghcOpts       :: [GHCOption]+  -- | If 'True', 'browse' also returns operators.+  , operators     :: Bool+  -- | If 'True', 'browse' also returns types.+  , detailed      :: Bool+  -- | If 'True', 'browse' will return fully qualified name+  , qualified     :: Bool+  -- | Line separator string.+  , lineSeparator :: LineSeparator+  }++-- | A default 'Options'.+defaultOptions :: Options+defaultOptions = Options {+    outputStyle   = PlainStyle+  , hlintOpts     = []+  , ghcOpts       = []+  , operators     = False+  , detailed      = False+  , qualified     = False+  , lineSeparator = LineSeparator "\0"+  }++----------------------------------------------------------------++type Builder = String -> String++-- |+--+-- >>> replace '"' "\\\"" "foo\"bar" ""+-- "foo\\\"bar"+replace :: Char -> String -> String -> Builder+replace _ _  [] = id+replace c cs (x:xs)+  | x == c    = (cs ++) . replace c cs xs+  | otherwise = (x :) . replace c cs xs++inter :: Char -> [Builder] -> Builder+inter _ [] = id+inter c bs = foldr1 (\x y -> x . (c:) . y) bs++convert :: ToString a => Options -> a -> String+convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"+convert opt@Options { outputStyle = PlainStyle } x+  | str == "\n" = ""+  | otherwise   = str+  where+    str = toPlain opt x "\n"++class ToString a where+    toLisp  :: Options -> a -> Builder+    toPlain :: Options -> a -> Builder++lineSep :: Options -> String+lineSep opt = lsep+  where+    LineSeparator lsep = lineSeparator opt++-- |+--+-- >>> toLisp defaultOptions "fo\"o" ""+-- "\"fo\\\"o\""+-- >>> toPlain defaultOptions "foo" ""+-- "foo"+instance ToString String where+    toLisp  opt = quote opt+    toPlain opt = replace '\n' (lineSep opt)++-- |+--+-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""+-- "(\"foo\" \"bar\" \"ba\\\"z\")"+-- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""+-- "foo\nbar\nbaz"+instance ToString [String] where+    toLisp  opt = toSexp1 opt+    toPlain opt = inter '\n' . map (toPlain opt)++-- |+--+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]+-- >>> toLisp defaultOptions inp ""+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"+-- >>> toPlain defaultOptions inp ""+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""+instance ToString [((Int,Int,Int,Int),String)] where+    toLisp  opt = toSexp2 . map toS+      where+        toS x = ('(' :) . tupToString opt x . (')' :)+    toPlain opt = inter '\n' . map (tupToString opt)++toSexp1 :: Options -> [String] -> Builder+toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)++toSexp2 :: [Builder] -> Builder+toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)++tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder+tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)+                              . (show b ++) . (' ' :)+                              . (show c ++) . (' ' :)+                              . (show d ++) . (' ' :)+                              . quote opt s -- fixme: quote is not necessary++quote :: Options -> String -> Builder+quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+  where+    lsep = lineSep opt+    quote' [] = []+    quote' (x:xs)+      | x == '\n' = lsep   ++ quote' xs+      | x == '\\' = "\\\\" ++ quote' xs+      | x == '"'  = "\\\"" ++ quote' xs+      | otherwise = x       : quote' xs++----------------------------------------------------------------++-- | The environment where this library is used.+data Cradle = Cradle {+  -- | The directory where this library is executed.+    cradleCurrentDir :: FilePath+  -- | The project root directory.+  , cradleRootDir    :: FilePath+  -- | The file name of the found cabal file.+  , cradleCabalFile  :: Maybe FilePath+  -- | Package database stack+  , cradlePkgDbStack  :: [GhcPkgDb]+  } deriving (Eq, Show)++----------------------------------------------------------------++-- | GHC package database flags.+data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)++-- | A single GHC command line option.+type GHCOption  = String++-- | An include directory for modules.+type IncludeDir = FilePath++-- | A package name.+type PackageBaseName = String++-- | A package version.+type PackageVersion  = String++-- | A package id.+type PackageId  = String++-- | A package's name, verson and id.+type Package    = (PackageBaseName, PackageVersion, PackageId)++pkgName :: Package -> PackageBaseName+pkgName (n,_,_) = n++pkgVer :: Package -> PackageVersion+pkgVer (_,v,_) = v++pkgId :: Package -> PackageId+pkgId (_,_,i) = i++showPkg :: Package -> String+showPkg (n,v,_) = intercalate "-" [n,v]++showPkgId :: Package -> String+showPkgId (n,v,"") = intercalate "-" [n,v]+showPkgId (n,v,i)  = intercalate "-" [n,v,i]++-- | Haskell expression.+type Expression = String++-- | Module name.+type ModuleString = String++-- | Option information for GHC+data CompilerOptions = CompilerOptions {+    ghcOptions  :: [GHCOption]  -- ^ Command line options+  , includeDirs :: [IncludeDir] -- ^ Include directories for modules+  , depPackages :: [Package]    -- ^ Dependent package names+  } deriving (Eq, Show)++instance Alternative Ghc where+    x <|> y = x `GE.gcatch` (\(_ :: IOException) -> y)+    empty = undefined
+ src/hhpc.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Config (cProjectVersion)++import Control.Exception (Exception, Handler(..), ErrorCall(..))+import qualified Control.Exception as E+import Data.Typeable (Typeable)+import Data.Version (showVersion)+import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))+import qualified System.Console.GetOpt as O+import System.Directory (doesFileExist)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)++import Hhp+import Paths_hhp++----------------------------------------------------------------++progVersion :: String+progVersion = "hhpc version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"++ghcOptHelp :: String+ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "++usage :: String+usage =    progVersion+        ++ "Usage:\n"+        ++ "\t hhpc list" ++ ghcOptHelp ++ "[-l] [-d]\n"+        ++ "\t hhpc lang [-l]\n"+        ++ "\t hhpc flag [-l]\n"+        ++ "\t hhpc browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"+        ++ "\t hhpc check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"+        ++ "\t hhpc expand" ++ ghcOptHelp ++ "<HaskellFiles...>\n"+        ++ "\t hhpc debug" ++ ghcOptHelp ++ "\n"+        ++ "\t hhpc info" ++ ghcOptHelp ++ "<HaskellFile> <expression>\n"+        ++ "\t hhpc type" ++ ghcOptHelp ++ "<HaskellFile> <line-no> <column-no>\n"+        ++ "\t hhpc find <symbol>\n"+        ++ "\t hhpc lint [-h opt] <HaskellFile>\n"+        ++ "\t hhpc root\n"+        ++ "\t hhpc doc <module>\n"+        ++ "\t hhpc boot\n"+        ++ "\t hhpc version\n"+        ++ "\t hhpc help\n"++----------------------------------------------------------------++argspec :: [OptDescr (Options -> Options)]+argspec = [ Option "l" ["tolisp"]+            (NoArg (\opts -> opts { outputStyle = LispStyle }))+            "print as a list of Lisp"+          , Option "h" ["hlintOpt"]+            (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")+            "hlint options"+          , Option "g" ["ghcOpt"]+            (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")+            "GHC options"+          , Option "o" ["operators"]+            (NoArg (\opts -> opts { operators = True }))+            "print operators, too"+          , Option "d" ["detailed"]+            (NoArg (\opts -> opts { detailed = True }))+            "print detailed info"+          , Option "q" ["qualified"]+            (NoArg (\opts -> opts { qualified = True }))+            "show qualified names"+          , Option "b" ["boundary"]+            (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")+            "specify line separator (default is Nul string)"+          ]++parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])+parseArgs spec argv+    = case O.getOpt Permute spec argv of+        (o,n,[]  ) -> (foldr id defaultOptions o, n)+        (_,_,errs) -> E.throw (CmdArg errs)++----------------------------------------------------------------++data HhpcError = SafeList+               | TooManyArguments String+               | NoSuchCommand String+               | CmdArg [String]+               | FileNotExist String deriving (Show, Typeable)++instance Exception HhpcError++----------------------------------------------------------------++main :: IO ()+main = flip E.catches handlers $ do+    hSetEncoding stdout utf8+    args <- getArgs+    let (opt,cmdArg) = parseArgs argspec args+    cradle <- findCradle+    let cmdArg0 = cmdArg !. 0+        cmdArg1 = cmdArg !. 1+        cmdArg2 = cmdArg !. 2+        cmdArg3 = cmdArg !. 3+        remainingArgs = tail cmdArg+        nArgs n f = if length remainingArgs == n+                        then f+                        else E.throw (TooManyArguments cmdArg0)+    res <- case cmdArg0 of+      "list"    -> listModules opt cradle+      "lang"    -> listLanguages opt+      "flag"    -> listFlags opt+      "browse"  -> concat <$> mapM (browseModule opt cradle) remainingArgs+      "check"   -> checkSyntax opt cradle remainingArgs+      "expand"  -> expandTemplate opt cradle remainingArgs+      "debug"   -> debugInfo opt cradle+      "info"    -> nArgs 2 infoExpr opt cradle cmdArg1 cmdArg2+      "type"    -> nArgs 3 $ typeExpr opt cradle cmdArg1 (read cmdArg2) (read cmdArg3)+      "find"    -> nArgs 1 $ findSymbol opt cradle cmdArg1+      "lint"    -> nArgs 1 withFile (lintSyntax opt) cmdArg1+      "root"    -> rootInfo opt cradle+      "doc"     -> nArgs 1 $ packageDoc opt cradle cmdArg1+      "boot"    -> bootInfo opt cradle+      "version" -> return progVersion+      "help"    -> return $ O.usageInfo usage argspec+      cmd       -> E.throw (NoSuchCommand cmd)+    putStr res+  where+    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]+    handleThenExit handler e = handler e >> exitFailure+    handler1 :: ErrorCall -> IO ()+    handler1 = print -- for debug+    handler2 :: HhpcError -> IO ()+    handler2 SafeList = printUsage+    handler2 (TooManyArguments cmd) = do+        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments"+        printUsage+    handler2 (NoSuchCommand cmd) = do+        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"+        printUsage+    handler2 (CmdArg errs) = do+        mapM_ (hPutStr stderr) errs+        printUsage+    handler2 (FileNotExist file) = do+        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"+        printUsage+    printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec+    withFile cmd file = do+        exist <- doesFileExist file+        if exist+            then cmd file+            else E.throw (FileNotExist file)+    xs !. idx+      | length xs <= idx = E.throw SafeList+      | otherwise = xs !! idx
+ src/hhpi.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE DeriveDataTypeable, CPP #-}++-- Commands:+--  check <file>+--  find <symbol>+--  info <file> <expr>+--  type <file> <line> <column>+--  lint [hlint options] <file>+--     the format of hlint options is [String] because they may contain+--     spaces and also <file> may contain spaces.+--  boot+--  browse [<package>:]<module>+--  quit+--+-- Session separators:+--   OK -- success+--   NG -- failure++module Main where++import Config (cProjectVersion)+import CoreMonad (liftIO)+import GHC (Ghc)+#if __GLASGOW_HASKELL__ >= 804+import GHC (mgModSummaries)+#endif+import qualified GHC as G++import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception (SomeException(..), Exception)+import qualified Control.Exception as E+import Control.Monad (when, void)+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Typeable (Typeable)+import Data.Version (showVersion)+import System.Console.GetOpt+import System.Directory (setCurrentDirectory)+import System.Environment (getArgs)+import System.IO (hFlush,stdout)++import Hhp+import Hhp.Ghc+-- import Hhp.Internal+import Paths_hhp++----------------------------------------------------------------++type Logger = IO String++----------------------------------------------------------------++progVersion :: String+progVersion = "hhpi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"++argspec :: [OptDescr (Options -> Options)]+argspec = [ Option "b" ["boundary"]+            (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")+            "specify line separator (default is Nul string)"+          , Option "l" ["tolisp"]+            (NoArg (\opts -> opts { outputStyle = LispStyle }))+            "print as a list of Lisp"+          , Option "g" []+            (ReqArg (\s opts -> opts { ghcOpts = s : ghcOpts opts }) "flag") "specify a ghc flag"+          ]++usage :: String+usage =    progVersion+        ++ "Usage:\n"+        ++ "\t hhpi [-l] [-b sep] [-g flag]\n"+        ++ "\t hhpi version\n"+        ++ "\t hhpi help\n"++parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])+parseArgs spec argv+    = case getOpt Permute spec argv of+        (o,n,[]  ) -> (foldr id defaultOptions o, n)+        (_,_,errs) -> E.throw (CmdArg errs)++----------------------------------------------------------------++newtype HhpiError = CmdArg [String] deriving (Show, Typeable)++instance Exception HhpiError++----------------------------------------------------------------++-- Running two GHC monad threads disables the handling of+-- C-c since installSignalHandlers is called twice, sigh.++main :: IO ()+main = E.handle cmdHandler $+    go =<< parseArgs argspec <$> getArgs+  where+    cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec+    go (_,"help":_) = putStr $ usageInfo usage argspec+    go (_,"version":_) = putStr progVersion+    go (opt,_) = E.handle someHandler $ do+        cradle0 <- findCradle+        let rootdir = cradleRootDir cradle0+            cradle = cradle0 { cradleCurrentDir = rootdir }+        setCurrentDirectory rootdir+        mvar <- liftIO newEmptyMVar+        mlibdir <- getSystemLibDir+        void $ forkIO $ setupDB cradle mlibdir opt mvar+        run cradle mlibdir opt $ loop opt S.empty mvar+      where+        -- this is just in case.+        -- If an error is caught here, it is a bug of Hhp library.+        someHandler (SomeException e) = do+            putStrLn $ "NG " ++ replace (show e)++replace :: String -> String+replace [] = []+replace ('\n':xs) = ';' : replace xs+replace (x:xs)    =  x  : replace xs++----------------------------------------------------------------++run :: Cradle -> Maybe FilePath -> Options -> Ghc a -> IO a+run cradle mlibdir opt body = G.runGhc mlibdir $ do+    initializeFlagsWithCradle opt cradle+    body++----------------------------------------------------------------++setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO ()+setupDB cradle mlibdir opt mvar = E.handle handler $ do+    db <- run cradle mlibdir opt getSymMdlDb+    putMVar mvar db+  where+    handler (SomeException _) = return () -- fixme: put emptyDb?++----------------------------------------------------------------++loop :: Options -> Set FilePath -> MVar SymMdlDb -> Ghc ()+loop opt set mvar = do+    cmdArg <- liftIO getLine+    let (cmd,arg') = break (== ' ') cmdArg+        arg = dropWhile (== ' ') arg'+    (ret,ok,set') <- case cmd of+        "check"  -> checkStx opt set arg+        "find"   -> findSym  opt set arg mvar+        "lint"   -> lintStx  opt set arg+        "info"   -> showInfo opt set arg+        "type"   -> showType opt set arg+        "boot"   -> bootIt   opt set+        "browse" -> browseIt opt set arg+        "quit"   -> return ("quit", False, set)+        ""       -> return ("quit", False, set)+        _        -> return ([], True, set)+    if ok then do+        liftIO $ putStr ret+        liftIO $ putStrLn "OK"+      else do+        liftIO $ putStrLn $ "NG " ++ replace ret+    liftIO $ hFlush stdout+    when ok $ loop opt set' mvar++----------------------------------------------------------------++checkStx :: Options+         -> Set FilePath+         -> FilePath+         -> Ghc (String, Bool, Set FilePath)+checkStx opt set file = do+    set' <- newFileSet set file+    let files = S.toList set'+    eret <- check opt files+    case eret of+        Right ret -> return (ret, True, set')+        Left ret  -> return (ret, True, set) -- fxime: set++newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath)+newFileSet set file = do+    let set1+         | S.member file set = set+         | otherwise         = S.insert file set+    mx <- isSameMainFile file <$> getModSummaryForMain+    return $ case mx of+        Nothing       -> set1+        Just mainfile -> S.delete mainfile set1++getModSummaryForMain :: Ghc (Maybe G.ModSummary)+#if __GLASGOW_HASKELL__ >= 804+getModSummaryForMain = find isMain . mgModSummaries <$> G.getModuleGraph+#else+getModSummaryForMain = find isMain <$> G.getModuleGraph+#endif+  where+    isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"++isSameMainFile :: FilePath -> Maybe G.ModSummary -> Maybe FilePath+isSameMainFile _    Nothing  = Nothing+isSameMainFile file (Just x)+    | mainfile == file = Nothing+    | otherwise        = Just mainfile+  where+    mmainfile = G.ml_hs_file (G.ms_location x)+    -- G.ms_hspp_file x is a temporary file with CPP.+    -- this is a just fake.+    mainfile = fromMaybe (G.ms_hspp_file x) mmainfile++----------------------------------------------------------------++findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb+        -> Ghc (String, Bool, Set FilePath)+findSym opt set sym mvar = do+    db <- liftIO $ readMVar mvar+    let ret = lookupSym opt sym db+    return (ret, True, set)++lintStx :: Options -> Set FilePath -> FilePath+        -> Ghc (String, Bool, Set FilePath)+lintStx opt set optFile = liftIO $ do+    ret <-lintSyntax opt' file+    return (ret, True, set)+  where+    (opts,file) = parseLintOptions optFile+    hopts = if opts == "" then [] else read opts+    opt' = opt { hlintOpts = hopts }++-- |+-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"+-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")+-- >>> parseLintOptions "file name"+-- ([], "file name")+parseLintOptions :: String -> (String, String)+parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of+    ("","")      -> ([],   optFile)+    (opt',file') -> (opt', dropWhile (== ' ') file')+  where+    brk _ []         =  ([],[])+    brk p (x:xs')+        | p x        =  ([x],xs')+        | otherwise  =  let (ys,zs) = brk p xs' in (x:ys,zs)++----------------------------------------------------------------++showInfo :: Options+         -> Set FilePath+         -> FilePath+         -> Ghc (String, Bool, Set FilePath)+showInfo opt set fileArg = do+    let [file, expr] = words fileArg+    set' <- newFileSet set file+    ret <- info opt file expr+    return (ret, True, set')++showType :: Options+         -> Set FilePath+         -> FilePath+         -> Ghc (String, Bool, Set FilePath)+showType opt set fileArg  = do+    let [file, line, column] = words fileArg+    set' <- newFileSet set file+    ret <- types opt file (read line) (read column)+    return (ret, True, set')++----------------------------------------------------------------++bootIt :: Options+       -> Set FilePath+       -> Ghc (String, Bool, Set FilePath)+bootIt opt set = do+    ret <- boot opt+    return (ret, True, set)++browseIt :: Options+         -> Set FilePath+         -> ModuleString+         -> Ghc (String, Bool, Set FilePath)+browseIt opt set mdl = do+    ret <- browse opt mdl+    return (ret, True, set)
+ test/BrowseSpec.hs view
@@ -0,0 +1,34 @@+module BrowseSpec where++import Test.Hspec++import Dir++import Hhp+import Hhp.Cradle++spec :: Spec+spec = do+    describe "browseModule" $ do+        it "lists up symbols in the module" $ do+            cradle <- findCradle+            syms <- lines <$> browseModule defaultOptions cradle "Data.Map"+            syms `shouldContain` ["differenceWithKey"]++    describe "browseModule -d" $ do+        it "lists up symbols with type info in the module" $ do+            cradle <- findCradle+            syms <- lines <$> browseModule defaultOptions { detailed = True } cradle "Data.Either"+            syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]++        it "lists up data constructors with type info in the module" $ do+            cradle <- findCradle+            syms <- lines <$> browseModule defaultOptions { detailed = True} cradle "Data.Either"+            syms `shouldContain` ["Left :: a -> Either a b"]++    describe "browseModule local" $ do+        it "lists symbols in a local module" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                syms <- lines <$> browseModule defaultOptions cradle "Baz"+                syms `shouldContain` ["baz"]
+ test/CabalApiSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ScopedTypeVariables #-}++module CabalApiSpec where++import Control.Exception+import Data.Maybe+import System.Directory+import System.FilePath+import Test.Hspec++import Hhp.CabalApi+import Hhp.Cradle+import Hhp.Types++import Dir++import Config (cProjectVersionInt) -- ghc version++ghcVersion :: Int+ghcVersion = read cProjectVersionInt+++spec :: Spec+spec = do+    describe "parseCabalFile" $ do+        it "throws an exception if the cabal file is broken" $ do+            parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True)++    describe "getCompilerOptions" $ do+        it "gets necessary CompilerOptions" $ do+            cwd <- getCurrentDirectory+            withDirectory "test/data/subdir1/subdir2" $ \dir -> do+                cradle <- findCradle+                pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle+                res <- getCompilerOptions [] cradle pkgDesc+                let res' = res {+                        ghcOptions  = ghcOptions res+                      , includeDirs = map (toRelativeDir dir) (includeDirs res)+                      }+                if ghcVersion < 706+                  then ghcOptions res' `shouldBe` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]+                  else ghcOptions res' `shouldBe` ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]+                includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]+                depPackages res' `shouldSatisfy` (("Cabal", "1.18.1.3", "2b161c6bf77657aa17e1681d83cb051b")`elem`)+++    describe "cabalDependPackages" $ do+        it "extracts dependent packages" $ do+            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"+            pkgs `shouldBe` ["Cabal","base","template-haskell"]++    describe "cabalSourceDirs" $ do+        it "extracts all hs-source-dirs" $ do+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal"+            dirs `shouldBe` ["src", "test"]+        it "extracts all hs-source-dirs including \".\"" $ do+            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"+            dirs `shouldBe` [".", "test"]++{-+    describe "cabalAllBuildInfo" $ do+        it "extracts build info" $ do+            info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"+            show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"+-}
+ test/CheckSpec.hs view
@@ -0,0 +1,44 @@+module CheckSpec where++import Data.List (isSuffixOf, isInfixOf, isPrefixOf)+import System.FilePath+import Test.Hspec++import Hhp+import Hhp.Cradle++import Dir++spec :: Spec+spec = do+    describe "checkSyntax" $ do+        it "can check even if an executable depends on its library" $ do+            withDirectory_ "test/data/hhp-check" $ do+                cradle <- findCradleWithoutSandbox+                res <- checkSyntax defaultOptions cradle ["main.hs"]+                res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"++        it "can check even if a test module imports another test module located at different directory" $ do+            withDirectory_ "test/data/check-test-subdir" $ do+                cradle <- findCradleWithoutSandbox+                res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"]+                res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)++        it "can detect mutually imported modules" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- checkSyntax defaultOptions cradle ["Mutual1.hs"]+                res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)++        it "can check a module using QuasiQuotes" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- checkSyntax defaultOptions cradle ["Baz.hs"]+                res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)++        context "without errors" $ do+            it "doesn't output empty line" $ do+                withDirectory_ "test/data/hhp-check/Data" $ do+                    cradle <- findCradleWithoutSandbox+                    res <- checkSyntax defaultOptions cradle ["Foo.hs"]+                    res `shouldBe` ""
+ test/Dir.hs view
@@ -0,0 +1,24 @@+module Dir where++import Control.Exception as E+import Data.List (isPrefixOf)+import System.Directory+import System.FilePath (addTrailingPathSeparator)++withDirectory_ :: FilePath -> IO a -> IO a+withDirectory_ dir action = bracket getCurrentDirectory+                                    setCurrentDirectory+                                    (\_ -> setCurrentDirectory dir >> action)++withDirectory :: FilePath -> (FilePath -> IO a) -> IO a+withDirectory dir action = bracket getCurrentDirectory+                                   setCurrentDirectory+                                   (\d -> setCurrentDirectory dir >> action d)++toRelativeDir :: FilePath -> FilePath -> FilePath+toRelativeDir dir file+  | dir' `isPrefixOf` file = drop len file+  | otherwise              = file+  where+    dir' = addTrailingPathSeparator dir+    len = length dir'
+ test/FlagSpec.hs view
@@ -0,0 +1,12 @@+module FlagSpec where++import Test.Hspec++import Hhp++spec :: Spec+spec = do+    describe "listFlags" $ do+        it "lists up GHC flags" $ do+            flags <- lines <$> listFlags defaultOptions+            flags `shouldContain` ["-Wno-orphans"]
+ test/GhcPkgSpec.hs view
@@ -0,0 +1,25 @@+module GhcPkgSpec where++import System.Directory+import System.FilePath ((</>))+import Test.Hspec++import Hhp.Types+import Hhp.GhcPkg++spec :: Spec+spec = do+    describe "getSandboxDb" $ do+        it "parses a config file and extracts sandbox package db" $ do+            cwd <- getCurrentDirectory+            pkgDb <- getSandboxDb "test/data/"+            pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")++        it "throws an error if a config file is broken" $ do+            getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException++    describe "getPackageDbPackages" $ do+        it "find a config file and extracts packages" $ do+            sdb <- getSandboxDb "test/data/check-packageid"+            pkgs <- ghcPkgListEx [PackageDb sdb]+            pkgs `shouldBe` [("template-haskell","2.8.0.0","32d4f24abdbb6bf41272b183b2e23e9c")]
+ test/InfoSpec.hs view
@@ -0,0 +1,61 @@+module InfoSpec where++import Data.List (isPrefixOf)+import System.Environment (getExecutablePath)+import System.Exit+import System.FilePath+import System.Process+import Test.Hspec++import Hhp+import Hhp.Cradle++import Dir++spec :: Spec+spec = do+    describe "typeExpr" $ do+        it "shows types of the expression and its outers" $ do+            withDirectory_ "test/data/hhp-check" $ do+                cradle <- findCradleWithoutSandbox+                res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5+                res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"++        it "works with a module using TemplateHaskell" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- typeExpr defaultOptions cradle "Bar.hs" 5 1+                res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]++        it "works with a module that imports another module using TemplateHaskell" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- typeExpr defaultOptions cradle "Main.hs" 3 8+                res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]++    describe "infoExpr" $ do+        it "works for non-export functions" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- infoExpr defaultOptions cradle "Info.hs" "fib"+                res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)++        it "works with a module using TemplateHaskell" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- infoExpr defaultOptions cradle "Bar.hs" "foo"+                res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)++        it "works with a module that imports another module using TemplateHaskell" $ do+            withDirectory_ "test/data" $ do+                cradle <- findCradleWithoutSandbox+                res <- infoExpr defaultOptions cradle "Main.hs" "bar"+                res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)++        it "doesn't fail on unicode output" $ do+            dir <- getDistDir+            code <- rawSystem (dir </> "build/hhpc/hhpc") ["info", "test/data/Unicode.hs", "unicode"]+            code `shouldSatisfy` (== ExitSuccess)++getDistDir :: IO FilePath+getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath
+ test/LangSpec.hs view
@@ -0,0 +1,12 @@+module LangSpec where++import Test.Hspec++import Hhp++spec :: Spec+spec = do+    describe "listLanguages" $ do+        it "lists up language extensions" $ do+            exts <- lines <$> listLanguages defaultOptions+            exts `shouldContain` ["OverloadedStrings"]
+ test/LintSpec.hs view
@@ -0,0 +1,17 @@+module LintSpec where++import Test.Hspec++import Hhp++spec :: Spec+spec = do+    describe "lintSyntax" $ do+        it "check syntax with HLint" $ do+            res <- lintSyntax defaultOptions "test/data/hlint.hs"+            res `shouldBe` "test/data/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULPerhaps:\NUL  putStrLn \"Hello, world!\"\n"++        context "without suggestions" $ do+            it "doesn't output empty line" $ do+                res <- lintSyntax defaultOptions "test/data/hhp-check/Data/Foo.hs"+                res `shouldBe` ""
+ test/ListSpec.hs view
@@ -0,0 +1,13 @@+module ListSpec where++import Test.Hspec++import Hhp++spec :: Spec+spec = do+    describe "listModules" $ do+        it "lists up module names" $ do+            cradle <- findCradle+            modules <- lines <$> listModules defaultOptions cradle+            modules `shouldContain` ["Data.Map"]
+ test/Main.hs view
@@ -0,0 +1,13 @@+import Spec+import Dir++import Test.Hspec+import System.Process++main :: IO ()+main = do+  let sandboxes = [ "test/data", "test/data/check-packageid" ]+      genSandboxCfg dir = withDirectory dir $ \cwdir -> do+         system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")+  genSandboxCfg `mapM_` sandboxes+  hspec spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf view
@@ -0,0 +1,4 @@+name: Cabal+version: 1.18.1.3+id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b+exposed: True
+ test/data/Bar.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module Bar (bar) where+import Foo (foo)++bar = $foo ++ "bar"
+ test/data/Baz.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}+module Baz (baz) where+import Foo (fooQ)++baz = [fooQ| foo bar baz |]
+ test/data/Foo.hs view
@@ -0,0 +1,9 @@+module Foo (foo, fooQ) where+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..))++foo :: ExpQ+foo = stringE "foo"++fooQ :: QuasiQuoter+fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined
+ test/data/Info.hs view
@@ -0,0 +1,6 @@+module Info () where++fib :: Int -> Int+fib 0 = 0+fib 1 = 1+fib n = fib (n - 1) + fib (n - 2)
+ test/data/Main.hs view
@@ -0,0 +1,3 @@+import Bar (bar)++main = putStrLn bar
+ test/data/Mutual1.hs view
@@ -0,0 +1,3 @@+module Mutual1 where++import Mutual2
+ test/data/Mutual2.hs view
@@ -0,0 +1,3 @@+module Mutual2 where++import Mutual1
+ test/data/Unicode.hs view
@@ -0,0 +1,4 @@+module Unicode where++unicode :: α -> α+unicode = id
+ test/data/broken-cabal/broken.cabal view
@@ -0,0 +1,1 @@+broken cabal
+ test/data/broken-sandbox/cabal.sandbox.config view
@@ -0,0 +1,1 @@+broken
+ test/data/broken-sandbox/dummy.cabal view
@@ -0,0 +1,1 @@+dummy
+ test/data/cabal.sandbox.config.in view
@@ -0,0 +1,25 @@+-- This is a Cabal package environment file.+-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.+-- Please create a 'cabal.config' file in the same directory+-- if you want to change the default settings for this sandbox.+++local-repo: @CWD@/test/data/.cabal-sandbox/packages+logs-dir: @CWD@/test/data/.cabal-sandbox/logs+world-file: @CWD@/test/data/.cabal-sandbox/world+user-install: False+package-db: @CWD@/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d+build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log++install-dirs+  prefix: @CWD@/test/data/.cabal-sandbox+  bindir: $prefix/bin+  libdir: $prefix/lib+  libsubdir: $arch-$os-$compiler/$pkgid+  libexecdir: $prefix/libexec+  datadir: $prefix/share+  datasubdir: $arch-$os-$compiler/$pkgid+  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid+  htmldir: $docdir/html+  haddockdir: $htmldir+  sysconfdir: $prefix/etc
+ test/data/cabalapi.cabal view
@@ -0,0 +1,63 @@+Name:                   hhp+Version:                0.0.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Homepage:               https://github.com/kazu-yamamoto/hhp+Synopsis:               Happy Haskell Programming+Description:            The hhp command is a backend command to enrich+                        Haskell programming on editors.+                        The hhpc/hhpi commands are based on HHP library+                        which is a wrapper of GHC API and Cabal API.+                        This package includes the hhpc command,+                        the hhpi command,+                        the HHP library, and Emacs front-end.+                        For more information, please see its home page.+Category:               Development+Cabal-Version:          >= 1.6+Build-Type:             Simple+Data-Dir:               elisp+Data-Files:             Makefile hhp.el hhp-func.el hhp-doc.el hhp-comp.el+                        hhp-check.el hhp-process.el hhp-command.el hhp-info.el+                        hhp-ins-mod.el hhp-indent.el hhp-pkg.el++Executable hhpc+  Main-Is:              hhpc.hs+  Other-Modules:        Browse+                        CabalApi+                        Cabal+                        CabalDev+                        Check+                        ErrMsg+                        Flag+                        GHCApi+                        GHCChoice+                        Gap+                        Info+                        Lang+                        Lint+                        List+                        Types+  GHC-Options:          -Wall+  Build-Depends:        base >= 4.0 && < 5+                      , Cabal >= 1.10+                      , template-haskell++Test-Suite spec+  Main-Is:              Spec.hs+  Hs-Source-Dirs:       test, .+  Type:                 exitcode-stdio-1.0+  Other-Modules:        Expectation+                        BrowseSpec+                        CabalApiSpec+                        FlagSpec+                        LangSpec+                        LintSpec+                        ListSpec+  Build-Depends:        base >= 4.0 && < 5+                      , Cabal >= 1.10++Source-Repository head+  Type:                 git+  Location:             git://github.com/kazu-yamamoto/hhp.git
+ test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf view
@@ -0,0 +1,4 @@+name: template-haskell+version: 2.8.0.0+id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c+exposed: True
+ test/data/check-packageid/cabal.sandbox.config.in view
@@ -0,0 +1,25 @@+-- This is a Cabal package environment file.+-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.+-- Please create a 'cabal.config' file in the same directory+-- if you want to change the default settings for this sandbox.+++local-repo: @CWD@/test/data/.cabal-sandbox/packages+logs-dir: @CWD@/test/data/.cabal-sandbox/logs+world-file: @CWD@/test/data/.cabal-sandbox/world+user-install: False+package-db: test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d+build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log++install-dirs+  prefix: @CWD@/test/data/.cabal-sandbox+  bindir: $prefix/bin+  libdir: $prefix/lib+  libsubdir: $arch-$os-$compiler/$pkgid+  libexecdir: $prefix/libexec+  datadir: $prefix/share+  datasubdir: $arch-$os-$compiler/$pkgid+  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid+  htmldir: $docdir/html+  haddockdir: $htmldir+  sysconfdir: $prefix/etc
+ test/data/check-test-subdir/check-test-subdir.cabal view
@@ -0,0 +1,15 @@+name: check-test-subdir+version: 0.1.0+build-type: Simple+cabal-version: >= 1.8++library+  build-depends: base == 4.*+  hs-source-dirs: src+  exposed-modules: Check.Test.Subdir++test-suite test+  type: exitcode-stdio-1.0+  build-depends: base == 4.*+  hs-source-dirs: test+  main-is: Main.hs
+ test/data/check-test-subdir/src/Check/Test/Subdir.hs view
@@ -0,0 +1,4 @@+module Check.Test.Subdir (subdir) where++subdir :: String+subdir = "subdir"
+ test/data/check-test-subdir/test/Bar/Baz.hs view
@@ -0,0 +1,5 @@+module Bar.Baz (baz) where+import Foo (foo)++baz :: String+baz = unwords [foo, "baz"]
+ test/data/check-test-subdir/test/Foo.hs view
@@ -0,0 +1,3 @@+module Foo (foo) where++foo = "foo"
+ test/data/check-test-subdir/test/Main.hs view
@@ -0,0 +1,5 @@+module Main where+import Bar.Baz (baz)++main :: IO ()+main = putStrLn baz
+ test/data/hhp-check/Data/Foo.hs view
@@ -0,0 +1,11 @@+module Data.Foo where++foo :: Int+foo = undefined++fibonacci :: Int -> Integer+fibonacci n = fib 1 0 1+  where+    fib m x y+      | n == m    = y+      | otherwise = fib (m+1) y (x + y)
+ test/data/hhp-check/hhp-check.cabal view
@@ -0,0 +1,27 @@+-- Initial hhpc-check.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                hhpc-check+version:             0.1.0.0+synopsis:            check test+-- description:+license:             BSD3+license-file:        LICENSE+author:              Kazu Yamamoto+maintainer:          kazu@iij.ad.jp+-- copyright:+category:            Data+build-type:          Simple+cabal-version:       >=1.8++library+  -- exposed-modules:+  -- other-modules:+  build-depends:       base+  exposed-modules:     Data.Foo++executable foo+  Main-Is:              main.hs+  GHC-Options:          -Wall+  Build-Depends:        base >= 4 && < 5+                      , hhpc-check
+ test/data/hhp-check/main.hs view
@@ -0,0 +1,5 @@+module Main where++import Data.Foo++main = print foo
+ test/data/hlint.hs view
@@ -0,0 +1,5 @@+module Hlist where++main :: IO ()+main = do+    putStrLn "Hello, world!"
+ test/data/subdir1/subdir2/dummy view
@@ -0,0 +1,1 @@+dummy
+ test/doctests.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest [+    "-package"+  , "ghc"+  , "-ilib/"+  , "-idist/build/autogen/"+  , "-optP-include"+  , "-optPdist/build/autogen/cabal_macros.h"+  , "lib/Hhp.hs"+  ]