diff --git a/Browse.hs b/Browse.hs --- a/Browse.hs +++ b/Browse.hs @@ -1,124 +1,23 @@ module Browse (browseModule) where -import Control.Applicative hiding ((<|>), many) +import Control.Applicative import Data.Char import Data.List -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Parser hiding (parse) -import Language.Haskell.Exts.Syntax -import System.IO -import System.Process -import Text.Parsec -import Text.Parsec.String -import Param +import GHC +import Name +import Types ---------------------------------------------------------------- browseModule :: Options -> String -> IO String -browseModule opt mname = convert opt . nub . sort . parseSyntax . preprocess <$> getSyntax opt mname - -getSyntax :: Options -> String -> IO String -getSyntax opt mname = do - (inp,out,_,_) <- runInteractiveProcess (ghci opt) [] Nothing Nothing - mapM_ setFD [inp,out] - hPutStrLn inp ":set prompt \"\"" - hPutStrLn inp "1" - hPutStrLn inp $ ":browse " ++ mname - hPutStrLn inp ":set prompt \"Prelude>\"" - hPutStrLn inp ":quit" - cs <- hGetContents out - return $ unlines $ dropTailer $ dropHeader $ lines $ cs - where - isNotPrefixOf x y = not (x `isPrefixOf` y) - dropHeader xs = tail $ dropWhile (isNotPrefixOf "Prelude>") xs - dropTailer = takeWhile (isNotPrefixOf "Prelude>") - setFD h = do - hSetBinaryMode h False - hSetBuffering h LineBuffering - -parseSyntax :: String -> [String] -parseSyntax xs = do - let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts } - res = parseModuleWithMode mode xs - case res of - ParseOk x -> identifiers x - _ -> [] - - ----------------------------------------------------------------- - -preprocess :: String -> String -preprocess cs = case parse remove "remove" cs of - Right a -> a - Left e -> error $ show e - -modName :: Parser String -modName = (:) <$> (oneOf ['A'..'Z']) - <*> (many . oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#") - -anyName :: Parser String -anyName = many1 . oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#" - -manyBefore :: Show tok => GenParser tok st a -> GenParser tok st [tok] -> GenParser tok st [a] -manyBefore p anchor = manyTill p (eof <|> try anc) - where - anc = do - pos <- getPosition - s <- anchor - ss <- getInput - setInput $ s ++ ss - setPosition pos - return () - -keyword :: Parser String -keyword = (++) <$> modName <*> string "." - -ghcName :: Parser String -ghcName = do - keyword - try sep <|> end +browseModule opt mdlName = convert opt . validate <$> browse mdlName where - sep = last <$> sepBy1 anyName (char '.') - end = "" <$ endBy1 anyName (char '.') - -nonGhcName :: Parser String -nonGhcName = (:) <$> anyChar <*> manyBefore anyChar keyword - -remove :: Parser String -remove = do - l1 <- try ghcName <|> return "" - l2 <- nonGhcName - ll <- many (do x <- ghcName - y <- nonGhcName - return $ x ++ y) - return $ concat $ l1 : l2 : ll - ----------------------------------------------------------------- + validate = sort . filter (isAlpha.head) -identifiers :: Module -> [String] -identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x +browse :: String -> IO [String] +browse mdlName = withGHC $ do + initSession0 + maybeNamesToStrings <$> lookupModuleInfo where - hid = all (\c -> isAlphaNum c || elem c "_'") - -decl :: Decl -> [String] -decl (TypeSig _ [x] _) = [name x] -decl (DataDecl _ _ _ x _ y _) = name x : (map qualConDecl y) -decl (ClassDecl _ _ x _ _ y) = name x : (map classDecl y) -decl (TypeDecl _ x _ _) = [name x] -decl x = [show x] - -qualConDecl :: QualConDecl -> String -qualConDecl (QualConDecl _ _ _ x) = conDecl x - -conDecl :: ConDecl -> String -conDecl (ConDecl (Ident x) _) = x -conDecl (InfixConDecl _ (Ident x) _) = x -conDecl x = show x - -classDecl :: ClassDecl -> String -classDecl (ClsDecl x) = concat $ decl x -- xxx -classDecl x = show x - -name :: Name -> String -name (Symbol x) = x -name (Ident x) = x + lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo + maybeNamesToStrings = maybe [] (map getOccString . modInfoExports) diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -1,53 +1,93 @@ -{-# LANGUAGE CPP #-} - module Check (checkSyntax) where +import Bag import Control.Applicative -import Control.Monad -import Data.Char -import Data.List -import Param -import System.Directory -import System.FilePath -import System.IO -import System.Process +import Data.IORef +import DynFlags +import ErrUtils +import Exception +import FastString +import GHC +import HscTypes +import Outputable hiding (showSDoc) +import Pretty +import Types +import Prelude hiding (catch) ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String -checkSyntax opt file = do - makeDirectory (outDir opt) -#if __GLASGOW_HASKELL__ >= 611 - (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall","-fno-warn-unused-do-bind",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out","-i..","-i../..","-i../../..","-i../../../..","-i../../../../.."] Nothing Nothing -#else - (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out","-i..","-i../..","-i../../..","-i../../../..","-i../../../../.."] Nothing Nothing -#endif - hSetBinaryMode herr False - refine <$> hGetContents herr - where - refine = unfoldLines . remove . lines - remove = filter (\x -> not ("Linking" `isPrefixOf` x)) - . filter (\x -> not ("[" `isPrefixOf` x)) - . filter (/="") +checkSyntax _ file = unlines <$> check file -unfoldLines :: [String] -> String -unfoldLines [] = "" -unfoldLines (x:xs) = x ++ unfold xs +---------------------------------------------------------------- + +check :: String -> IO [String] +check fileName = withGHC $ do + ref <- liftIO $ newIORef [] + initSession + setTargetFile fileName + loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref + clearWarnings + liftIO $ readIORef ref where - unfold [] = "\n" - unfold (l:ls) - | isAlpha (head l) = ('\n':l) ++ unfold ls - | otherwise = (drop 4 l) ++ "\0" ++ unfold ls + -- I don't know why, but parseDynamicFlags must be used. + initSession = do + dflags <- getSessionDynFlags + (dflags',_,_) <- parseDynamicFlags dflags cmdOptions + setSessionDynFlags $ setFlags dflags' + setTargetFile file = do + target <- guessTarget file Nothing + setTargets [target] + handleParseError ref e = do + liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e + return Succeeded +-- I don't know why, but parseDynamicFlags must be used. +cmdOptions :: [Located String] +cmdOptions = map noLoc ["-Wall","-fno-warn-unused-do-bind"] + ---------------------------------------------------------------- -makeDirectory :: FilePath -> IO () -makeDirectory dir = makeDirectoryRecur $ normalise dir - where - makeDirectoryRecur "" = return () - makeDirectoryRecur cur = do - exist <- doesDirectoryExist cur - let par = takeDirectory cur - unless exist $ do - makeDirectoryRecur par - createDirectory cur +refLogger :: IORef [String] -> WarnErrLogger +refLogger ref Nothing = + (errBagToStrList <$> getWarnings) >>= liftIO . writeIORef ref +refLogger ref (Just e) = + liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e + +errBagToStrList :: Bag ErrMsg -> [String] +errBagToStrList = map showErrMsg . reverse . bagToList + +---------------------------------------------------------------- + +setFlags :: DynFlags -> DynFlags +setFlags d = d { + importPaths = importPaths d ++ importDirs + , packageFlags = ghcPackage : packageFlags d + , ghcLink = NoLink +-- GHC.desugarModule does not produces the pattern warnings, why? +-- , hscTarget = HscNothing + , hscTarget = HscInterpreted + } + +importDirs :: [String] +importDirs = ["..","../..","../../..","../../../../.."] + +ghcPackage :: PackageFlag +ghcPackage = ExposePackage "ghc" + +---------------------------------------------------------------- + +showErrMsg :: ErrMsg -> String +showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg + where + spn = head (errMsgSpans err) + file = unpackFS (srcSpanFile spn) + line = show (srcSpanStartLine spn) + col = show (srcSpanStartCol spn) + msg = showSDoc (errMsgShortDoc err) + +style :: PprStyle +style = mkUserStyle neverQualify AllTheWay + +showSDoc :: SDoc -> String +showSDoc d = Pretty.showDocWith OneLineMode (d style) diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -2,50 +2,45 @@ import Browse import Check +import Control.Applicative import Control.Exception hiding (try) -import List -import Param import Lang +import Lint +import List import Prelude hiding (catch) import System.Console.GetOpt +import System.Directory import System.Environment (getArgs) +import Types ---------------------------------------------------------------- usage :: String -usage = "ghc-mod version 0.2.0\n" +usage = "ghc-mod version 0.4.0\n" ++ "Usage:\n" ++ "\t ghc-mod list\n" - ++ "\t ghc-mod browse \n" + ++ "\t ghc-mod lang\n" + ++ "\t ghc-mod browse [ ...]\n" ++ "\t ghc-mod check \n" + ++ "\t ghc-mod lint \n" + ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" ---------------------------------------------------------------- defaultOptions :: Options -defaultOptions = Options { convert = toPlain - , ghc = "ghc" - , ghci = "ghci" - , ghcPkg = "ghc-pkg" - , outDir = "dist/flymake" - } +defaultOptions = Options { + convert = toPlain + , hlint = "hlint" + } argspec :: [OptDescr (Options -> Options)] -argspec = [ Option ['l'] ["tolisp"] +argspec = [ Option "l" ["tolisp"] (NoArg (\opts -> opts { convert = toLisp })) "print as a list of Lisp" - , Option ['g'] ["ghc"] - (ReqArg (\str opts -> opts { ghc = str }) "ghc") - "GHC path" - , Option ['i'] ["ghci"] - (ReqArg (\str opts -> opts { ghci = str }) "ghci") - "ghci path" - , Option ['p'] ["ghc-pkg"] - (ReqArg (\str opts -> opts { ghcPkg = str }) "ghc-pkg") - "ghc-pkg path" - , Option ['o'] ["output-dir"] - (ReqArg (\str opts -> opts { outDir = str }) "dist/flymake") - "output directory" + , Option "f" ["hlint"] + (ReqArg (\str opts -> opts { hlint = str }) "hlint") + "path to hlint" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) @@ -60,16 +55,27 @@ main = flip catch handler $ do args <- getArgs let (opt,cmdArg) = parseArgs argspec args - res <- case cmdArg !! 0 of - "browse" -> browseModule opt (cmdArg !! 1) + res <- case head cmdArg of + "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt - "check" -> checkSyntax opt (cmdArg !! 1) + "check" -> withFile (checkSyntax opt) (cmdArg !! 1) + "lint" -> withFile (lintSyntax opt) (cmdArg !! 1) "lang" -> listLanguages opt + "boot" -> do + mods <- listModules opt + langs <- listLanguages opt + pre <- browseModule opt "Prelude" + return $ mods ++ langs ++ pre _ -> error usage putStr res where handler :: ErrorCall -> IO () handler _ = putStr usage + withFile cmd file = do + exist <- doesFileExist file + if exist + then cmd file + else return "" ---------------------------------------------------------------- toLisp :: [String] -> String diff --git a/Lang.hs b/Lang.hs --- a/Lang.hs +++ b/Lang.hs @@ -1,14 +1,7 @@ module Lang where -import Control.Applicative -import Param -import System.IO -import System.Process +import DynFlags +import Types listLanguages :: Options -> IO String -listLanguages opt = convert opt . lines <$> getLangs opt - -getLangs :: Options -> IO String -getLangs opt = do - (_,hout,_,_) <- runInteractiveProcess (ghc opt) ["--supported-languages"] Nothing Nothing - hGetContents hout +listLanguages opt = return $ convert opt supportedLanguages diff --git a/Lint.hs b/Lint.hs new file mode 100644 --- /dev/null +++ b/Lint.hs @@ -0,0 +1,20 @@ +module Lint where + +import Control.Applicative +import Data.List +import System.IO +import System.Process +import Types + +lintSyntax :: Options -> String -> IO String +lintSyntax cmd file = pretty <$> lint cmd file + where + pretty = unlines . map (concat . intersperse "\0") + . filter (\x -> length x > 1) + . groupBy (\a b -> a /= "" && b /= "") + . lines + +lint :: Options -> String -> IO String +lint cmd file = do + (_,hout,_,_) <- runInteractiveProcess (hlint cmd) ["-i","Use camelCase",file] Nothing Nothing + hGetContents hout diff --git a/List.hs b/List.hs --- a/List.hs +++ b/List.hs @@ -2,53 +2,21 @@ import Control.Applicative import Data.List -import Param -import System.IO -import System.Process +import GHC +import Packages +import Types +import UniqFM ---------------------------------------------------------------- listModules :: Options -> IO String -listModules opt = convert opt . nub . sort . exposedModules <$> getDump opt - -getDump :: Options -> IO String -getDump opt = do - (_,hout,_,_) <- runInteractiveProcess (ghcPkg opt) ["dump"] Nothing Nothing - hGetContents hout - -exposedModules :: String -> [String] -exposedModules cs = results - where - ls = unfoldLines cs - ns = values "name: " ls - ms = values "exposed-modules: " ls - zs = zip ns ms - xs = filter (\(nm,_) -> nm `notElem` ["ghc", "ghc-prim", "rts", "integer"]) zs - ss = map snd xs - results = filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss - -values :: String -> [String] -> [String] -values tag ls = value - where - value = map (drop len) fs - len = length tag - fs = filter (tag `isPrefixOf`) ls - ----------------------------------------------------------------- +listModules opt = convert opt . nub . sort <$> list -unfoldLines :: String -> [String] -unfoldLines xs = self xs +list :: IO [String] +list = withGHC $ do + initSession0 + getExposedModules <$> getSessionDynFlags where - splitNL = break (== '\n') - self "" = [] - self s = let (l, s') = splitNL s - in case s' of - [] -> [l] - (_:' ':s'') -> cont s'' l - (_:s'') -> l : self s'' - cont s a = let (l, s') = splitNL $ dropWhile (== ' ') s - a' = a ++ " " ++ l - in case s' of - [] -> [a'] - (_:' ':s'') -> cont s'' a' - (_:s'') -> a' : self s'' + getExposedModules = map moduleNameString + . concatMap exposedModules + . eltsUFM . pkgIdMap . pkgState diff --git a/Param.hs b/Param.hs deleted file mode 100644 --- a/Param.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Param where - -data Options = Options { convert :: [String] -> String - , ghc :: FilePath - , ghci :: FilePath - , ghcPkg :: FilePath - , outDir :: FilePath - } - diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,19 @@ +module Types where + +import Exception +import GHC +import GHC.Paths (libdir) + +data Options = Options { + convert :: [String] -> String + , hlint :: String + } + +withGHC :: Ghc [String] -> IO [String] +withGHC body = ghandle ignore $ runGhc (Just libdir) body + where + ignore :: SomeException -> IO [String] + ignore _ = return [] + +initSession0 :: Ghc [PackageId] +initSession0 = getSessionDynFlags >>= setSessionDynFlags diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -47,11 +47,15 @@ (defvar ghc-loaded-module nil) (defun ghc-comp-init () - (setq ghc-module-names (cons "hiding" (cons "qualified" (ghc-load-keyword "list")))) - (setq ghc-language-extensions (cons "LANGUAGE" (ghc-load-keyword "lang"))) - (setq ghc-keyword-Prelude (ghc-load-keyword "browse" "Prelude")) - (setq ghc-loaded-module '("Prelude")) - (ghc-merge-keywords) + (let* ((syms '(ghc-module-names + ghc-language-extensions + ghc-keyword-Prelude)) + (vals (ghc-boot (length syms)))) + (ghc-set syms vals)) + (ghc-add ghc-module-names "qualified") + (ghc-add ghc-module-names "hiding") + (ghc-add ghc-language-extensions "LANGUAGE") + (ghc-merge-keywords '("Prelude")) (run-with-idle-timer ghc-idle-timer-interval 'repeat 'ghc-idle-timer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -59,17 +63,27 @@ ;;; Executing command ;;; -(defun ghc-load-keyword (&rest args) +(defun ghc-boot (n) (if (not (ghc-which ghc-module-command)) (message "%s not found" ghc-module-command) - (ghc-read-lisp + (ghc-read-lisp-list (lambda () - (let ((msg (mapconcat 'identity (cons ghc-module-command args) " "))) - (message "Executing \"%s\"..." msg) - (apply 'call-process ghc-module-command nil t nil - (append '("-l") (ghc-module-command-args) args)) - (message "Executing \"%s\"...done" msg)))))) + (message "Initializing...") + (call-process ghc-module-command nil t nil "-l" "boot") + (message "Initializing...done")) + n))) +(defun ghc-load-modules (mods) + (if (not (ghc-which ghc-module-command)) + (message "%s not found" ghc-module-command) + (ghc-read-lisp-list + (lambda () + (message "Loading names...") + (apply 'call-process ghc-module-command nil t nil + (cons "-l" (cons "browse" mods))) + (message "Loading names...done")) + (length mods)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Completion @@ -166,57 +180,73 @@ ;;; Loading keywords ;;; -(add-hook 'find-file-hook 'ghc-load-module-buffer) +(add-hook 'find-file-hook 'ghc-import-module) -(defun ghc-load-module-buffer () +(defun ghc-import-module () (interactive) (when (eq major-mode 'haskell-mode) - (mapc 'ghc-load-module (ghc-gather-import-modules-buffer)))) + (ghc-load-module-buffer))) -(defun ghc-load-module (mod) - (when (and (member mod ghc-module-names) - (not (member mod ghc-loaded-module))) - (let ((keywords (ghc-load-keyword "browse" mod))) - (when (or (consp keywords) (null keywords)) - (set (intern (concat ghc-keyword-prefix mod)) keywords) - (setq ghc-loaded-module (cons mod ghc-loaded-module)))))) +(defun ghc-unloaded-modules (mods) + (ghc-filter (lambda (mod) + (and (member mod ghc-module-names) + (not (member mod ghc-loaded-module)))) + mods)) -(defun ghc-merge-keywords () +(defun ghc-load-module-all-buffers () + (ghc-load-merge-modules (ghc-gather-import-modules-all-buffers))) + +(defun ghc-load-module-buffer () + (ghc-load-merge-modules (ghc-gather-import-modules-buffer))) + +(defun ghc-load-merge-modules (mods) + (let* ((umods (ghc-unloaded-modules mods)) + (syms (mapcar 'ghc-module-symbol umods)) + (names (ghc-load-modules umods))) + (ghc-set syms names) + (ghc-merge-keywords umods))) + +(defun ghc-merge-keywords (mods) + (setq ghc-loaded-module (append mods ghc-loaded-module)) (let* ((modkeys (mapcar 'ghc-module-keyword ghc-loaded-module)) (keywords (cons ghc-reserved-keyword modkeys)) (uniq-sorted (sort (ghc-uniq-lol keywords) 'string<))) (setq ghc-merged-keyword uniq-sorted))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Background Idle Timer -;;; +(defun ghc-module-symbol (mod) + (intern (concat ghc-keyword-prefix mod))) -(defun ghc-idle-timer () - (dolist (mod (ghc-gather-import-modules)) - (ghc-load-module mod)) - (ghc-merge-keywords)) +(defun ghc-module-keyword (mod) + (symbol-value (ghc-module-symbol mod))) -(defun ghc-gather-import-modules () + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-gather-import-modules-all-buffers () (let ((bufs (mapcar 'buffer-name (buffer-list))) ret) (save-excursion - (dolist (buf bufs) + (dolist (buf bufs (ghc-uniq-lol ret)) (when (string-match "\\.hs$" buf) (set-buffer buf) - (setq ret (cons (ghc-gather-import-modules-buffer) ret))))) - (ghc-uniq-lol ret))) + (ghc-add ret (ghc-gather-import-modules-buffer))))))) (defun ghc-gather-import-modules-buffer () (let (ret) (save-excursion (goto-char (point-min)) - (while (re-search-forward "^import *\\([^\n ]+\\)" nil t) - (setq ret (cons (match-string-no-properties 1) ret)) + (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t) + (ghc-add ret (match-string-no-properties 2)) (forward-line))) ret)) -(defun ghc-module-keyword (mod) - (symbol-value (intern (concat ghc-keyword-prefix mod)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Background Idle Timer +;;; + +(defalias 'ghc-idle-timer 'ghc-load-module-all-buffer) + +(defun ghc-load-module-all-buffer () nil) (provide 'ghc-comp) diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -58,4 +58,16 @@ (make-sparse-keymap))) (define-key ghc-input-map "\t" 'ghc-complete)) +(defun ghc-read-module-name (def) + (read-from-minibuffer "Module name: " def ghc-input-map)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-extract-module () + (interactive) + (save-excursion + (beginning-of-line) + (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)") + (match-string-no-properties 3)))) + (provide 'ghc-doc) diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -30,48 +30,77 @@ (let ((after-save-hook nil)) (save-buffer)) (let ((file (file-name-nondirectory (buffer-file-name)))) - (list ghc-module-command (append (ghc-module-command-args) - (list "check" file))))) + (list ghc-module-command (ghc-flymake-command file)))) +(defvar ghc-hlint (ghc-which "hlint")) + +(defvar ghc-flymake-command nil) ;; nil: check, t: lint + +(defun ghc-flymake-command (file) + (if ghc-flymake-command + (list "-f" ghc-hlint "lint" file) + (list "check" file))) + +(defun ghc-flymake-toggle-command () + (interactive) + (setq ghc-flymake-command (not ghc-flymake-command)) + (if ghc-flymake-command + (message "Syntax check with hlint") + (message "Syntax check with GHC"))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-display-errors () +(defun ghc-flymake-display-errors () (interactive) - (let* ((data (ghc-flymake-data)) - (buf (get-buffer-create ghc-error-buffer-name))) - (with-current-buffer buf - (erase-buffer) - (ghc-insert-errors data)) - (display-buffer buf))) + (if (not (ghc-flymake-have-errs-p)) + (message "No errors or warnings") + (let ((buf (get-buffer-create ghc-error-buffer-name)) + (title (ghc-flymake-err-title)) + (errs (ghc-flymake-err-list))) + (with-current-buffer buf + (erase-buffer) + (ghc-flymake-insert-errors title errs)) + (display-buffer buf)))) -(defun ghc-insert-errors (data) - (let ((title (nth 0 data)) - (errs (nth 1 data))) +(defun ghc-flymake-insert-errors (title errs) + (save-excursion (insert title "\n") - (dolist (err errs) - (insert (ghc-replace-character (car err) 0 10) "\n")) - (goto-char (point-min)))) + (mapc (lambda (x) (insert (ghc-replace-character x ghc-null ghc-newline) "\n")) errs))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-flymake-insert-type () +(defun ghc-flymake-insert-from-warning () (interactive) - (let ((data (ghc-flymake-first-data))) - (if (and data - (string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data)) - (progn + (dolist (data (ghc-flymake-err-list)) + (save-excursion + (cond + ((string-match "Inferred type: \\([^:]+ :: \\)\\(forall [^.]+\\. \\)?\\([^\0]*\\)" data) (beginning-of-line) (insert (match-string 1 data) (match-string 3 data) "\n")) - (message "No inferred type")))) + ((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")))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ghc-flymake-err-get-title (x) (nth 0 x)) +(defun ghc-flymake-err-get-errs (x) (nth 1 x)) + +(defalias 'ghc-flymake-have-errs-p 'ghc-flymake-data) + (defun ghc-flymake-data () (let* ((line-no (flymake-current-line-no)) (info (nth 0 (flymake-find-err-info flymake-err-info line-no)))) (flymake-make-err-menu-data line-no info))) -(defun ghc-flymake-first-data () - (nth 0 (nth 0 (nth 1 (ghc-flymake-data))))) +(defun ghc-flymake-err-title () + (ghc-flymake-err-get-title (ghc-flymake-data))) + +(defun ghc-flymake-err-list () + (mapcar 'car (ghc-flymake-err-get-errs (ghc-flymake-data)))) (provide 'ghc-flymake) diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -8,6 +8,10 @@ ;;; Code: +(defvar ghc-module-command "ghc-mod") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun ghc-replace-character (string from to) "Replace characters equal to FROM to TO in STRING." (let ((ret (copy-sequence string))) @@ -15,6 +19,25 @@ (if (char-equal (aref ret cnt) from) (aset ret cnt to))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro ghc-add (sym val) + `(setq ,sym (cons ,val ,sym))) + +(defun ghc-set (vars vals) + (dolist (var vars) + (if var (set var (car vals))) ;; var can be nil to skip + (setq vals (cdr vals)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ghc-filter (pred lst) + (let (ret) + (dolist (x lst (reverse ret)) + (if (funcall pred x) (ghc-add ret x))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun ghc-which (cmd) (catch 'loop (dolist (suffix '("" ".exe")) @@ -24,15 +47,19 @@ (if (file-exists-p path) (throw 'loop path)))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun ghc-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) (setq ret (cons key ret))) hash) + (maphash (lambda (key val) (ghc-add ret key)) hash) ret)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun ghc-read-lisp (func) (with-temp-buffer (funcall func) @@ -41,26 +68,20 @@ (read (current-buffer)) (error ())))) -(defun ghc-extract-module () - (interactive) - (save-excursion - (beginning-of-line) - (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)") - (match-string-no-properties 3)))) - -(defun ghc-read-module-name (def) - (read-from-minibuffer "Module name: " def ghc-input-map)) +(defun ghc-read-lisp-list (func n) + (with-temp-buffer + (funcall func) + (goto-char (point-min)) + (condition-case nil + (let ((m (set-marker (make-marker) 1 (current-buffer))) + ret) + (dotimes (i n (nreverse ret)) + (ghc-add ret (read m)))) + (error ())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ghc-module-command "ghc-mod") -(defvar ghc-ghc-command (ghc-which "ghc")) -(defvar ghc-ghci-command (ghc-which "ghci")) -(defvar ghc-ghc-pkg-command (ghc-which "ghc-pkg")) - -(defun ghc-module-command-args () - (list "-g" ghc-ghc-command - "-i" ghc-ghci-command - "-p" ghc-ghc-pkg-command)) +(defconst ghc-null 0) +(defconst ghc-newline 10) (provide 'ghc-func) 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.2.0") +(defvar ghc-version "0.4.0") ;; (eval-when-compile ;; (require 'haskell-mode)) @@ -24,6 +24,8 @@ (require 'ghc-comp) (require 'ghc-doc) (require 'ghc-flymake) +(require 'ghc-command) +(require 'dabbrev) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -36,7 +38,10 @@ (defvar ghc-previous-key "\ep") (defvar ghc-next-key "\en") (defvar ghc-help-key "\e?") -(defvar ghc-insert-type-key "\et") +(defvar ghc-insert-key "\et") +(defvar ghc-sort-key "\es") +(defvar ghc-check-key "\C-x\C-s") +(defvar ghc-toggle-key "\C-c\C-c") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -46,15 +51,23 @@ (defvar ghc-initialized nil) (defun ghc-init () + (ghc-abbrev-init) (unless ghc-initialized (define-key haskell-mode-map ghc-completion-key 'ghc-complete) (define-key haskell-mode-map ghc-document-key 'ghc-browse-document) - (define-key haskell-mode-map ghc-import-key 'ghc-load-module-buffer) + (define-key haskell-mode-map ghc-import-key 'ghc-import-module) (define-key haskell-mode-map ghc-previous-key 'flymake-goto-prev-error) (define-key haskell-mode-map ghc-next-key 'flymake-goto-next-error) - (define-key haskell-mode-map ghc-help-key 'ghc-display-errors) - (define-key haskell-mode-map ghc-insert-type-key 'ghc-flymake-insert-type) + (define-key haskell-mode-map ghc-help-key 'ghc-flymake-display-errors) + (define-key haskell-mode-map ghc-insert-key 'ghc-insert-template) + (define-key haskell-mode-map ghc-sort-key 'ghc-sort-lines) + (define-key haskell-mode-map ghc-check-key 'ghc-save-buffer) + (define-key haskell-mode-map ghc-toggle-key 'ghc-flymake-toggle-command) (ghc-comp-init) (setq ghc-initialized t))) + +(defun ghc-abbrev-init () + (make-local-variable 'dabbrev-case-fold-search) + (setq dabbrev-case-fold-search nil)) (provide 'ghc) 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.3.0 +Version: 0.4.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -23,14 +23,13 @@ ghc-flymake.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Check Param Lang + Other-Modules: List Browse Check Lang Lint Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5, - parsec >= 3, process, haskell-src-exts, - directory, filepath + Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, + process, directory, filepath Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git