ghc-mod 4.0.1 → 4.0.2
raw patch · 8 files changed
+134/−47 lines, 8 files
Files
- elisp/ghc-check.el +43/−13
- elisp/ghc-command.el +3/−2
- elisp/ghc-func.el +12/−11
- elisp/ghc-ins-mod.el +3/−1
- elisp/ghc-process.el +6/−5
- elisp/ghc.el +9/−1
- ghc-mod.cabal +1/−1
- src/GHCModi.hs +57/−13
elisp/ghc-check.el view
@@ -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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-command.el view
@@ -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)
elisp/ghc-func.el view
@@ -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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-ins-mod.el view
@@ -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
elisp/ghc-process.el view
@@ -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
elisp/ghc.el view
@@ -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))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 4.0.1+Version: 4.0.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3
src/GHCModi.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} -- Commands: -- check <file>@@ -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 ----------------------------------------------------------------