diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,2 @@ +2018-12-18 v0.0.0 + * First release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elisp/Makefile b/elisp/Makefile new file mode 100644 --- /dev/null +++ b/elisp/Makefile @@ -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)/ diff --git a/elisp/hhp-check.el b/elisp/hhp-check.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-check.el @@ -0,0 +1,353 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-check.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-command.el b/elisp/hhp-command.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-command.el @@ -0,0 +1,96 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-command.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-comp.el b/elisp/hhp-comp.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-comp.el @@ -0,0 +1,277 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-comp.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-doc.el b/elisp/hhp-doc.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-doc.el @@ -0,0 +1,107 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-doc.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-func.el b/elisp/hhp-func.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-func.el @@ -0,0 +1,216 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-func.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-indent.el b/elisp/hhp-indent.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-indent.el @@ -0,0 +1,21 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-indent.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-info.el b/elisp/hhp-info.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-info.el @@ -0,0 +1,162 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-info.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-ins-mod.el b/elisp/hhp-ins-mod.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-ins-mod.el @@ -0,0 +1,79 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-ins-mod.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp-pkg.el b/elisp/hhp-pkg.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-pkg.el @@ -0,0 +1,5 @@ +(define-package + "hhp" + 0.0.0 + "Sub mode for Haskell mode" + nil) diff --git a/elisp/hhp-process.el b/elisp/hhp-process.el new file mode 100644 --- /dev/null +++ b/elisp/hhp-process.el @@ -0,0 +1,149 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; hhp-process.el +;;; + +;; Author: Kazu Yamamoto +;; 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) diff --git a/elisp/hhp.el b/elisp/hhp.el new file mode 100644 --- /dev/null +++ b/elisp/hhp.el @@ -0,0 +1,142 @@ +;;; hhp.el --- hhp front-end for haskell-mode + +;; Author: Kazu Yamamoto +;; 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) diff --git a/hhp.cabal b/hhp.cabal new file mode 100644 --- /dev/null +++ b/hhp.cabal @@ -0,0 +1,176 @@ +Name: hhp +Version: 0.0.0 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +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 diff --git a/lib/Hhp.hs b/lib/Hhp.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp.hs @@ -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 diff --git a/lib/Hhp/Boot.hs b/lib/Hhp/Boot.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Boot.hs @@ -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" + ] diff --git a/lib/Hhp/Browse.hs b/lib/Hhp/Browse.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Browse.hs @@ -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 diff --git a/lib/Hhp/CabalApi.hs b/lib/Hhp/CabalApi.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/CabalApi.hs @@ -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 diff --git a/lib/Hhp/Check.hs b/lib/Hhp/Check.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Check.hs @@ -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 diff --git a/lib/Hhp/Cradle.hs b/lib/Hhp/Cradle.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Cradle.hs @@ -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 diff --git a/lib/Hhp/Debug.hs b/lib/Hhp/Debug.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Debug.hs @@ -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 diff --git a/lib/Hhp/Doc.hs b/lib/Hhp/Doc.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Doc.hs @@ -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 } diff --git a/lib/Hhp/Find.hs b/lib/Hhp/Find.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Find.hs @@ -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 diff --git a/lib/Hhp/Flag.hs b/lib/Hhp/Flag.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Flag.hs @@ -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-"] + ] diff --git a/lib/Hhp/GHCApi.hs b/lib/Hhp/GHCApi.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/GHCApi.hs @@ -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 diff --git a/lib/Hhp/Gap.hs b/lib/Hhp/Gap.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Gap.hs @@ -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 diff --git a/lib/Hhp/Ghc.hs b/lib/Hhp/Ghc.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Ghc.hs @@ -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 diff --git a/lib/Hhp/GhcPkg.hs b/lib/Hhp/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/GhcPkg.hs @@ -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] diff --git a/lib/Hhp/Info.hs b/lib/Hhp/Info.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Info.hs @@ -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) diff --git a/lib/Hhp/Internal.hs b/lib/Hhp/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Internal.hs @@ -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 diff --git a/lib/Hhp/Lang.hs b/lib/Hhp/Lang.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Lang.hs @@ -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 diff --git a/lib/Hhp/Lint.hs b/lib/Hhp/Lint.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Lint.hs @@ -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" diff --git a/lib/Hhp/List.hs b/lib/Hhp/List.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/List.hs @@ -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 ] diff --git a/lib/Hhp/Logger.hs b/lib/Hhp/Logger.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Logger.hs @@ -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 diff --git a/lib/Hhp/PkgDoc.hs b/lib/Hhp/PkgDoc.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/PkgDoc.hs @@ -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") diff --git a/lib/Hhp/Syb.hs b/lib/Hhp/Syb.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Syb.hs @@ -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 diff --git a/lib/Hhp/Things.hs b/lib/Hhp/Things.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Things.hs @@ -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) diff --git a/lib/Hhp/Types.hs b/lib/Hhp/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Hhp/Types.hs @@ -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 diff --git a/src/hhpc.hs b/src/hhpc.hs new file mode 100644 --- /dev/null +++ b/src/hhpc.hs @@ -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] [:] [[:] ...]\n" + ++ "\t hhpc check" ++ ghcOptHelp ++ "\n" + ++ "\t hhpc expand" ++ ghcOptHelp ++ "\n" + ++ "\t hhpc debug" ++ ghcOptHelp ++ "\n" + ++ "\t hhpc info" ++ ghcOptHelp ++ " \n" + ++ "\t hhpc type" ++ ghcOptHelp ++ " \n" + ++ "\t hhpc find \n" + ++ "\t hhpc lint [-h opt] \n" + ++ "\t hhpc root\n" + ++ "\t hhpc doc \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 diff --git a/src/hhpi.hs b/src/hhpi.hs new file mode 100644 --- /dev/null +++ b/src/hhpi.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +-- Commands: +-- check +-- find +-- info +-- type +-- lint [hlint options] +-- the format of hlint options is [String] because they may contain +-- spaces and also may contain spaces. +-- boot +-- browse [:] +-- 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) diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs new file mode 100644 --- /dev/null +++ b/test/BrowseSpec.hs @@ -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"] diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/CabalApiSpec.hs @@ -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 = []})))]}]" +-} diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/CheckSpec.hs @@ -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` "" diff --git a/test/Dir.hs b/test/Dir.hs new file mode 100644 --- /dev/null +++ b/test/Dir.hs @@ -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' diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs new file mode 100644 --- /dev/null +++ b/test/FlagSpec.hs @@ -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"] diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs new file mode 100644 --- /dev/null +++ b/test/GhcPkgSpec.hs @@ -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")] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/InfoSpec.hs @@ -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 diff --git a/test/LangSpec.hs b/test/LangSpec.hs new file mode 100644 --- /dev/null +++ b/test/LangSpec.hs @@ -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"] diff --git a/test/LintSpec.hs b/test/LintSpec.hs new file mode 100644 --- /dev/null +++ b/test/LintSpec.hs @@ -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` "" diff --git a/test/ListSpec.hs b/test/ListSpec.hs new file mode 100644 --- /dev/null +++ b/test/ListSpec.hs @@ -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"] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf b/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf new file mode 100644 --- /dev/null +++ b/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf @@ -0,0 +1,4 @@ +name: Cabal +version: 1.18.1.3 +id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b +exposed: True diff --git a/test/data/Bar.hs b/test/data/Bar.hs new file mode 100644 --- /dev/null +++ b/test/data/Bar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Bar (bar) where +import Foo (foo) + +bar = $foo ++ "bar" diff --git a/test/data/Baz.hs b/test/data/Baz.hs new file mode 100644 --- /dev/null +++ b/test/data/Baz.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module Baz (baz) where +import Foo (fooQ) + +baz = [fooQ| foo bar baz |] diff --git a/test/data/Foo.hs b/test/data/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/Foo.hs @@ -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 diff --git a/test/data/Info.hs b/test/data/Info.hs new file mode 100644 --- /dev/null +++ b/test/data/Info.hs @@ -0,0 +1,6 @@ +module Info () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/Main.hs b/test/data/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/Main.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/data/Mutual1.hs b/test/data/Mutual1.hs new file mode 100644 --- /dev/null +++ b/test/data/Mutual1.hs @@ -0,0 +1,3 @@ +module Mutual1 where + +import Mutual2 diff --git a/test/data/Mutual2.hs b/test/data/Mutual2.hs new file mode 100644 --- /dev/null +++ b/test/data/Mutual2.hs @@ -0,0 +1,3 @@ +module Mutual2 where + +import Mutual1 diff --git a/test/data/Unicode.hs b/test/data/Unicode.hs new file mode 100644 --- /dev/null +++ b/test/data/Unicode.hs @@ -0,0 +1,4 @@ +module Unicode where + +unicode :: α -> α +unicode = id diff --git a/test/data/broken-cabal/broken.cabal b/test/data/broken-cabal/broken.cabal new file mode 100644 --- /dev/null +++ b/test/data/broken-cabal/broken.cabal @@ -0,0 +1,1 @@ +broken cabal diff --git a/test/data/broken-sandbox/cabal.sandbox.config b/test/data/broken-sandbox/cabal.sandbox.config new file mode 100644 --- /dev/null +++ b/test/data/broken-sandbox/cabal.sandbox.config @@ -0,0 +1,1 @@ +broken diff --git a/test/data/broken-sandbox/dummy.cabal b/test/data/broken-sandbox/dummy.cabal new file mode 100644 --- /dev/null +++ b/test/data/broken-sandbox/dummy.cabal @@ -0,0 +1,1 @@ +dummy diff --git a/test/data/cabal.sandbox.config.in b/test/data/cabal.sandbox.config.in new file mode 100644 --- /dev/null +++ b/test/data/cabal.sandbox.config.in @@ -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 diff --git a/test/data/cabalapi.cabal b/test/data/cabalapi.cabal new file mode 100644 --- /dev/null +++ b/test/data/cabalapi.cabal @@ -0,0 +1,63 @@ +Name: hhp +Version: 0.0.0 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +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 diff --git a/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf b/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf new file mode 100644 --- /dev/null +++ b/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf @@ -0,0 +1,4 @@ +name: template-haskell +version: 2.8.0.0 +id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c +exposed: True diff --git a/test/data/check-packageid/cabal.sandbox.config.in b/test/data/check-packageid/cabal.sandbox.config.in new file mode 100644 --- /dev/null +++ b/test/data/check-packageid/cabal.sandbox.config.in @@ -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 diff --git a/test/data/check-test-subdir/check-test-subdir.cabal b/test/data/check-test-subdir/check-test-subdir.cabal new file mode 100644 --- /dev/null +++ b/test/data/check-test-subdir/check-test-subdir.cabal @@ -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 diff --git a/test/data/check-test-subdir/src/Check/Test/Subdir.hs b/test/data/check-test-subdir/src/Check/Test/Subdir.hs new file mode 100644 --- /dev/null +++ b/test/data/check-test-subdir/src/Check/Test/Subdir.hs @@ -0,0 +1,4 @@ +module Check.Test.Subdir (subdir) where + +subdir :: String +subdir = "subdir" diff --git a/test/data/check-test-subdir/test/Bar/Baz.hs b/test/data/check-test-subdir/test/Bar/Baz.hs new file mode 100644 --- /dev/null +++ b/test/data/check-test-subdir/test/Bar/Baz.hs @@ -0,0 +1,5 @@ +module Bar.Baz (baz) where +import Foo (foo) + +baz :: String +baz = unwords [foo, "baz"] diff --git a/test/data/check-test-subdir/test/Foo.hs b/test/data/check-test-subdir/test/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/check-test-subdir/test/Foo.hs @@ -0,0 +1,3 @@ +module Foo (foo) where + +foo = "foo" diff --git a/test/data/check-test-subdir/test/Main.hs b/test/data/check-test-subdir/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/check-test-subdir/test/Main.hs @@ -0,0 +1,5 @@ +module Main where +import Bar.Baz (baz) + +main :: IO () +main = putStrLn baz diff --git a/test/data/hhp-check/Data/Foo.hs b/test/data/hhp-check/Data/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/hhp-check/Data/Foo.hs @@ -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) diff --git a/test/data/hhp-check/hhp-check.cabal b/test/data/hhp-check/hhp-check.cabal new file mode 100644 --- /dev/null +++ b/test/data/hhp-check/hhp-check.cabal @@ -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 diff --git a/test/data/hhp-check/main.hs b/test/data/hhp-check/main.hs new file mode 100644 --- /dev/null +++ b/test/data/hhp-check/main.hs @@ -0,0 +1,5 @@ +module Main where + +import Data.Foo + +main = print foo diff --git a/test/data/hlint.hs b/test/data/hlint.hs new file mode 100644 --- /dev/null +++ b/test/data/hlint.hs @@ -0,0 +1,5 @@ +module Hlist where + +main :: IO () +main = do + putStrLn "Hello, world!" diff --git a/test/data/subdir1/subdir2/dummy b/test/data/subdir1/subdir2/dummy new file mode 100644 --- /dev/null +++ b/test/data/subdir1/subdir2/dummy @@ -0,0 +1,1 @@ +dummy diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -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" + ]