diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -78,13 +78,14 @@ ---------------------------------------------------------------- showErrMsg :: ErrMsg -> String -showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg +showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext where spn = head (errMsgSpans err) file = unpackFS (srcSpanFile spn) line = show (srcSpanStartLine spn) col = show (srcSpanStartCol spn) msg = showSDoc (errMsgShortDoc err) + ext = showSDoc (errMsgExtraInfo err) style :: PprStyle style = mkUserStyle neverQualify AllTheWay diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -1,28 +1,32 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module Main where import Browse import Check import Control.Applicative -import Control.Exception hiding (try) +import Control.Exception +import Data.Typeable import Lang import Lint import List -import Prelude hiding (catch) +import Prelude import System.Console.GetOpt import System.Directory import System.Environment (getArgs) +import System.IO (hPutStr, hPutStrLn, stderr) import Types ---------------------------------------------------------------- usage :: String -usage = "ghc-mod version 0.4.1\n" +usage = "ghc-mod version 0.4.2\n" ++ "Usage:\n" - ++ "\t ghc-mod list\n" - ++ "\t ghc-mod lang\n" - ++ "\t ghc-mod browse [ ...]\n" + ++ "\t ghc-mod [-l] list\n" + ++ "\t ghc-mod [-l] lang\n" + ++ "\t ghc-mod [-l] browse [ ...]\n" ++ "\t ghc-mod check \n" - ++ "\t ghc-mod lint \n" + ++ "\t ghc-mod [-h opt] lint \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -31,51 +35,76 @@ defaultOptions :: Options defaultOptions = Options { convert = toPlain - , hlint = "hlint" + , hlintOpts = [] } argspec :: [OptDescr (Options -> Options)] argspec = [ Option "l" ["tolisp"] (NoArg (\opts -> opts { convert = toLisp })) "print as a list of Lisp" - , Option "f" ["hlint"] - (ReqArg (\str opts -> opts { hlint = str }) "hlint") - "path to hlint" + , Option "h" ["hlintOpt"] + (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt") + "hint to be ignored" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) parseArgs spec argv = case getOpt Permute spec argv of (o,n,[] ) -> (foldl (flip id) defaultOptions o, n) - (_,_,errs) -> error $ concat errs ++ usageInfo usage argspec + (_,_,errs) -> throw (CmdArg errs) ---------------------------------------------------------------- +data GHCModError = SafeList + | NoSuchCommand String + | CmdArg [String] + | FileNotExist String deriving (Show, Typeable) + +instance Exception GHCModError + +---------------------------------------------------------------- + main :: IO () -main = flip catch handler $ do +main = flip catches handlers $ do args <- getArgs let (opt,cmdArg) = parseArgs argspec args - res <- case head cmdArg of + res <- case safelist cmdArg 0 of "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt - "check" -> withFile (checkSyntax opt) (cmdArg !! 1) - "lint" -> withFile (lintSyntax opt) (cmdArg !! 1) + "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) + "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "boot" -> do mods <- listModules opt langs <- listLanguages opt pre <- browseModule opt "Prelude" return $ mods ++ langs ++ pre - _ -> error usage + cmd -> throw (NoSuchCommand cmd) putStr res where - handler :: ErrorCall -> IO () - handler _ = putStr usage + handlers = [Handler handler1, Handler handler2] + handler1 :: ErrorCall -> IO () + handler1 e = print e -- for debug + handler2 :: GHCModError -> IO () + handler2 SafeList = 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" ++ usageInfo usage argspec withFile cmd file = do exist <- doesFileExist file if exist then cmd file - else return "" + else throw (FileNotExist file) + safelist xs idx + | length xs <= idx = throw SafeList + | otherwise = xs !! idx ---------------------------------------------------------------- toLisp :: [String] -> String diff --git a/Lint.hs b/Lint.hs --- a/Lint.hs +++ b/Lint.hs @@ -2,19 +2,13 @@ import Control.Applicative import Data.List -import System.IO -import System.Process +import Language.Haskell.HLint import Types lintSyntax :: Options -> String -> IO String -lintSyntax cmd file = pretty <$> lint cmd file +lintSyntax opt file = pretty <$> lint opt file where - pretty = unlines . map (concat . intersperse "\0") - . filter (\x -> length x > 1) - . groupBy (\a b -> a /= "" && b /= "") - . lines + pretty = unlines . map (concat . intersperse "\0" . lines) -lint :: Options -> String -> IO String -lint cmd file = do - (_,hout,_,_) <- runInteractiveProcess (hlint cmd) ["-i","Use camelCase",file] Nothing Nothing - hGetContents hout +lint :: Options -> String -> IO [String] +lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt) diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -5,8 +5,8 @@ import GHC.Paths (libdir) data Options = Options { - convert :: [String] -> String - , hlint :: String + convert :: [String] -> String + , hlintOpts :: [String] } withGHC :: Ghc [String] -> IO [String] diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -8,19 +8,19 @@ ;;; Code: -(provide 'ghc-flymake) +(require 'ghc-flymake) (defun ghc-insert-template () (interactive) (cond ((bobp) (ghc-insert-module-template)) + ((ghc-flymake-have-errs-p) + (ghc-flymake-insert-from-warning)) ((save-excursion (beginning-of-line) (looking-at "^[^ ]+ *::")) (ghc-insert-function-template)) - ((ghc-flymake-have-errs-p) - (ghc-flymake-insert-from-warning)) (t (message "Nothing to be done")))) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -15,13 +15,20 @@ ;;; Customize Variables ;;; -(defvar ghc-idle-timer-interval 30) +(defvar ghc-idle-timer-interval 30 + "*Period of idele timer in second. When timeout, the names of +unloaded modules are loaded") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Constants +;;; + ;; must be sorted -(defvar ghc-reserved-keyword-for-bol '("class" "data" "default" "import" "infix" "infixl" "infixr" "instance" "main" "module" "newtype" "type")) +(defconst ghc-reserved-keyword-for-bol '("class" "data" "default" "import" "infix" "infixl" "infixr" "instance" "main" "module" "newtype" "type")) ;; must be sorted -(defvar ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) +(defconst ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -42,7 +49,7 @@ (defvar ghc-merged-keyword nil) ;; completion for type/func/... (defvar ghc-language-extensions nil) -(defvar ghc-keyword-prefix "ghc-keyword-") +(defconst ghc-keyword-prefix "ghc-keyword-") (defvar ghc-keyword-Prelude nil) (defvar ghc-loaded-module nil) @@ -170,7 +177,7 @@ (defun ghc-completion-start-point () (save-excursion (let ((beg (save-excursion (beginning-of-line) (point)))) - (if (re-search-backward "[ (,`]" beg t) + (if (re-search-backward "[ (,`]" beg t) ;; xxx "." (1+ (point)) beg)))) diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -34,8 +34,8 @@ (when (looking-at "^haddock-html: \\([^ \n]+\\)$") (match-string-no-properties 1)))) -(defvar ghc-doc-local-format "file://%s/%s.html") -(defvar ghc-doc-hackage-format +(defconst ghc-doc-local-format "file://%s/%s.html") +(defconst ghc-doc-hackage-format "http://hackage.haskell.org/packages/archive/%s/latest/doc/html/%s.html") (defun ghc-display-document (pkg mod haskell-org) diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -10,12 +10,18 @@ (require 'flymake) -(defvar ghc-error-buffer-name "*GHC Errors*") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ghc-flymake-allowed-file-name-masks +(defvar ghc-hlint-options nil "*Hlint options") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst ghc-error-buffer-name "*GHC Errors*") + +(defconst ghc-flymake-allowed-file-name-masks '("\\.l?hs$" ghc-flymake-init flymake-simple-cleanup flymake-get-real-file-name)) -(defvar ghc-flymake-err-line-patterns +(defconst ghc-flymake-err-line-patterns '("^\\(.*\\.l?hs\\):\\([0-9]+\\):\\([0-9]+\\):[ ]*\\(.+\\)" 1 2 3 4)) (add-to-list 'flymake-allowed-file-name-masks @@ -30,15 +36,14 @@ (let ((after-save-hook nil)) (save-buffer)) (let ((file (file-name-nondirectory (buffer-file-name)))) - (list ghc-module-command (ghc-flymake-command file)))) - -(defvar ghc-hlint (ghc-which "hlint")) + (list ghc-module-command (ghc-flymake-command file ghc-hlint-options)))) (defvar ghc-flymake-command nil) ;; nil: check, t: lint -(defun ghc-flymake-command (file) +(defun ghc-flymake-command (file opts) (if ghc-flymake-command - (list "-f" ghc-hlint "lint" file) + (let ((hopts (ghc-mapconcat (lambda (x) (list "-h" x)) opts))) + `(,@hopts "lint" ,file)) (list "check" file))) (defun ghc-flymake-toggle-command () @@ -64,8 +69,14 @@ (defun ghc-flymake-insert-errors (title errs) (save-excursion - (insert title "\n") - (mapc (lambda (x) (insert (ghc-replace-character x ghc-null ghc-newline) "\n")) errs))) + (insert title "\n\n") + (mapc (lambda (x) (insert (ghc-replace-character x ghc-null ghc-newline) "\n")) errs) + (goto-char (point-min)) + (while (re-search-forward "In the [^:\n ]+: \\|Expected type: \\|Inferred type: \\|Possible fix: " nil t) + (replace-match (concat "\n" (match-string 0) "\n "))) + (goto-char (point-max)) + (while (re-search-backward "In the [a-z]+ argument\\|In the `" nil t) + (insert "\n")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -76,14 +87,24 @@ (cond ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data) (beginning-of-line) - (insert (match-string 1 data) (match-string 3 data) "\n")) + (insert (match-string 1 data) + (replace-regexp-in-string "\\[Char\\]" "String" (match-string 3 data)) + "\n")) ((string-match "Not in scope: `\\([^']+\\)'" data) (save-match-data (unless (re-search-forward "^$" nil t) (goto-char (point-max)) (insert "\n"))) - (insert "\n" (match-string 1 data) " = undefined\n")))))) - + (insert "\n" (match-string 1 data) " = undefined\n")) + ((string-match "Found:\0[ ]*\\([^\0]+\\)\0Why not:\0[ ]*\\([^\0]+\\)" data) + (let ((old (match-string 1 data)) + (new (match-string 2 data))) + (beginning-of-line) + (when (search-forward old nil t) + (let ((end (point))) + (search-backward old nil t) + (delete-region (point) end)) + (insert new)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -8,7 +8,8 @@ ;;; Code: -(defvar ghc-module-command "ghc-mod") +(defvar ghc-module-command "ghc-mod" +"*The command name of \"ghc-mod\"") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -78,6 +79,11 @@ (dotimes (i n (nreverse ret)) (ghc-add ret (read m)))) (error ())))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-mapconcat (func list) + (apply 'append (mapcar func list))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -16,7 +16,7 @@ ;;; Code: -(defvar ghc-version "0.4.0") +(defconst ghc-version "0.4.0") ;; (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: 0.4.1 +Version: 0.4.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -29,7 +29,7 @@ else GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, - process, directory, filepath + process, directory, filepath, hlint >= 1.7.1 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git