diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -34,6 +34,14 @@ (defvar ghc-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark))) +(defvar ghc-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 ghc-check-syntax () @@ -64,7 +72,7 @@ (let ((regex "^\\([^\n\0]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\(.+\\)") info infos) (while (re-search-forward regex nil t) - (let* ((file (match-string 1)) + (let* ((file (expand-file-name (match-string 1))) ;; for Windows (line (string-to-number (match-string 2))) ;; don't take column to make multiple same errors to a single. (msg (match-string 4)) @@ -144,6 +152,22 @@ (insert (overlay-get (car ovls) 'ghc-file) "\n\n") (mapc (lambda (x) (insert x "\n\n")) errs)))))) +(defun ghc-display-errors-to-minibuf () + (interactive) + (let* ((ovls (ghc-check-overlay-at (point))) + (errs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls)) + (old-max-mini-window-height max-mini-window-height)) + (setq max-mini-window-height 0.95) + (if (null ovls) + (message "No errors or warnings") + (let* ((buffile buffer-file-name) + (ghcfile (overlay-get (car ovls) 'ghc-file)) + (errmsg (mapconcat (lambda (x) (replace-regexp-in-string "\0" "\n" x)) errs "\n"))) + (if (string-equal buffile ghcfile) + (message "%s" errmsg) + (message "%s\n\n%s" ghcfile errmsg)))) + (setq old-max-mini-window-height))) + (defun ghc-check-overlay-at (p) (let ((ovls (overlays-at p))) (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls))) @@ -153,22 +177,28 @@ (defun ghc-goto-prev-error () (interactive) (let* ((here (point)) - (ovls0 (ghc-check-overlay-at here)) - (end (if ovls0 (overlay-start (car ovls0)) here)) - (ovls1 (overlays-in (point-min) end)) - (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) - (pnts (mapcar 'overlay-start ovls2))) - (if pnts (goto-char (apply 'max pnts))))) + (ovls0 (ghc-check-overlay-at here)) + (end (if ovls0 (overlay-start (car ovls0)) here)) + (ovls1 (overlays-in (point-min) end)) + (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) + (pnts (mapcar 'overlay-start ovls2))) + (if pnts (goto-char (apply 'max pnts)))) + (cond + ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf)) + ((eq ghc-display-error 'other-buffer) (ghc-display-errors)))) (defun ghc-goto-next-error () (interactive) (let* ((here (point)) - (ovls0 (ghc-check-overlay-at here)) - (beg (if ovls0 (overlay-end (car ovls0)) here)) - (ovls1 (overlays-in beg (point-max))) - (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) - (pnts (mapcar 'overlay-start ovls2))) - (if pnts (goto-char (apply 'min pnts))))) + (ovls0 (ghc-check-overlay-at here)) + (beg (if ovls0 (overlay-end (car ovls0)) here)) + (ovls1 (overlays-in beg (point-max))) + (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) + (pnts (mapcar 'overlay-start ovls2))) + (if pnts (goto-char (apply 'min pnts)))) + (cond + ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf)) + ((eq ghc-display-error 'other-buffer) (ghc-display-errors)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -87,8 +87,9 @@ (if ghc-check-command ;; hlint (if (buffer-modified-p) (call-interactively 'save-buffer)) - (set-buffer-modified-p t) - (call-interactively 'save-buffer)) + (unless buffer-read-only + (set-buffer-modified-p t) + (call-interactively 'save-buffer))) (ghc-check-syntax)) (provide 'ghc-command) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -147,17 +147,18 @@ (defconst ghc-error-buffer-name "*GHC Info*") (defun ghc-display (fontify ins-func) - (let ((buf (get-buffer-create ghc-error-buffer-name))) - (with-current-buffer buf - (erase-buffer) - (funcall ins-func) - (ghc-replace-character-buffer ghc-null ghc-newline) - (goto-char (point-min)) - (if (not fontify) - (turn-off-haskell-font-lock) - (haskell-font-lock-defaults-create) - (turn-on-haskell-font-lock))) - (display-buffer buf))) + (let ((buf ghc-error-buffer-name)) + (with-output-to-temp-buffer buf + (with-current-buffer buf + (erase-buffer) + (funcall ins-func) + (ghc-replace-character-buffer ghc-null ghc-newline) + (goto-char (point-min)) + (if (not fontify) + (turn-off-haskell-font-lock) + (haskell-font-lock-defaults-create) + (turn-on-haskell-font-lock))) + (display-buffer buf)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-ins-mod.el b/elisp/ghc-ins-mod.el --- a/elisp/ghc-ins-mod.el +++ b/elisp/ghc-ins-mod.el @@ -22,7 +22,9 @@ (defvar ghc-preferred-modules '("Control.Applicative" "Data.ByteString" "Data.Text" - "Text.Parsec")) + "Text.Parsec" + "System.FilePath" + "System.Directory")) (defun ghc-reorder-modules (mods) (catch 'loop diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -24,11 +24,12 @@ (defun ghc-get-project-root () (let ((file (buffer-file-name))) - (with-temp-buffer - (ghc-call-process ghc-module-command nil t nil "root" file) - (goto-char (point-min)) - (when (looking-at "^\\(.*\\)$") - (match-string-no-properties 1))))) + (when file + (with-temp-buffer + (ghc-call-process ghc-module-command nil t nil "root" file) + (goto-char (point-min)) + (when (looking-at "^\\(.*\\)$") + (match-string-no-properties 1)))))) (defun ghc-with-process (send callback) (unless ghc-process-process-name diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -8,10 +8,18 @@ ;; ;; (autoload 'ghc-init "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) +;; +;; Or if you wish to display error each goto next/prev error, +;; set ghc-display-error valiable. +;; +;; (setq ghc-display-error 'minibuffer) ; to minibuffer +;; ; (setq ghc-display-error 'other-buffer) ; to other-buffer +;; + ;;; Code: -(defconst ghc-version "4.0.1") +(defconst ghc-version "4.0.2") ;; (eval-when-compile ;; (require 'haskell-mode)) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 4.0.1 +Version: 4.0.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 diff --git a/src/GHCModi.hs b/src/GHCModi.hs --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} -- Commands: -- check @@ -35,13 +36,18 @@ import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S +import Data.Typeable +import Data.Version (showVersion) import qualified Exception as GE import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile)) import qualified GHC as G import HscTypes (SourceError) import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal +import Paths_ghc_mod +import System.Console.GetOpt import System.Directory (setCurrentDirectory) +import System.Environment (getArgs) import System.IO (hFlush,stdout) ---------------------------------------------------------------- @@ -51,28 +57,66 @@ ---------------------------------------------------------------- +argspec :: [OptDescr (Options -> Options)] +argspec = [ Option "b" ["boundary"] + (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") + "specify line separator (default is Nul string)" + ] + +usage :: String +usage = "ghc-modi version " ++ showVersion version ++ "\n" + ++ "Usage:\n" + ++ "\t ghc-modi [-b sep]\n" + ++ "\t ghc-modi 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) -> GE.throw (CmdArg errs) + +---------------------------------------------------------------- + +data GHCModiError = CmdArg [String] + deriving (Show, Typeable) + +instance GE.Exception GHCModiError + +---------------------------------------------------------------- + -- Running two GHC monad threads disables the handling of -- C-c since installSignalHandlers is called twice, sigh. main :: IO () -main = E.handle handler $ 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 S.empty ls mvar +main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $ + go =<< parseArgs argspec <$> getArgs where - opt = defaultOptions - ls = lineSeparator opt - LineSeparator lsc = ls - handler (SomeException e) = do + handle = flip GE.catches + LineSeparator lsc = lineSeparator defaultOptions + cmdHandler (CmdArg e) = do putStr "ghc-modi:0:0:" + let x = intercalate lsc e + putStrLn x + putStr $ usageInfo usage argspec + putStrLn "NG" + someHandler (SomeException e) = do + putStr "ghc-modi:0:0:" let x = intercalate lsc $ lines $ show e putStrLn x putStrLn "NG" + go (_,"help":_) = do + putStr $ usageInfo usage argspec + putStrLn "NG" + go (opt,_) = do + cradle0 <- findCradle + let rootdir = cradleRootDir cradle0 + cradle = cradle0 { cradleCurrentDir = rootdir } + ls = lineSeparator opt + setCurrentDirectory rootdir + mvar <- liftIO newEmptyMVar + mlibdir <- getSystemLibDir + void $ forkIO $ setupDB cradle mlibdir opt mvar + run cradle mlibdir opt $ loop S.empty ls mvar ----------------------------------------------------------------