From 1e445097b7adf07604f50b359b57a9cbd657b716 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 11 Mar 2010 19:03:17 +0900 Subject: [PATCH] integrating flymake. --- Browse.hs | 131 +++++++++++++++++++++++++++ Check.hs | 25 ++++++ GHCMod.hs | 206 ++++++------------------------------------- List.hs | 54 ++++++++++++ elisp/Makefile | 3 +- elisp/ghc-comp.el | 3 +- elisp/ghc-flymake.el | 23 +++++ elisp/ghc.el | 17 +++- ghc-mod.cabal | 4 +- 9 files changed, 282 insertions(+), 184 deletions(-) create mode 100644 Browse.hs create mode 100644 Check.hs create mode 100644 List.hs create mode 100644 elisp/ghc-flymake.el diff --git a/Browse.hs b/Browse.hs new file mode 100644 index 0000000..893349d --- /dev/null +++ b/Browse.hs @@ -0,0 +1,131 @@ +module Browse (browseModule) where + +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.ParserCombinators.Parsec + +---------------------------------------------------------------- + +browseModule :: String -> IO [String] +browseModule mname = do + xs <- getSyntax mname + let ys = preprocess xs + return $ parseSyntax ys + +getSyntax :: String -> IO String +getSyntax mname = do + (inp,out,_,_) <- runInteractiveProcess "ghci" [] 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 +-- e -> error $ show e + _ -> [] + + +---------------------------------------------------------------- + +preprocess :: String -> String +preprocess cs = case parse remove "remove" cs of + Right a -> a + Left e -> error $ show e + +modName :: Parser String +modName = do c <- oneOf ['A'..'Z'] + cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#" + return $ c:cs + +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 = do ms <- modName + char '.' + return $ ms ++ ['.'] + +ghcName :: Parser String +ghcName = do keyword + try sep <|> end + where + sep = do + ws <- sepBy1 anyName (char '.') + return $ last ws + end = do + endBy1 anyName (char '.') + return "" + +nonGhcName :: Parser String +nonGhcName = do c <- anyChar -- making this func non-empty + cs <- manyBefore anyChar keyword + return $ c:cs + +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 + +---------------------------------------------------------------- + +identifiers :: Module -> [String] +identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x + 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 diff --git a/Check.hs b/Check.hs new file mode 100644 index 0000000..828fe3e --- /dev/null +++ b/Check.hs @@ -0,0 +1,25 @@ +module Check (checkSyntax) where + +import Control.Applicative +import Data.Char +import Data.List +import System.IO +import System.Process + +---------------------------------------------------------------- + +checkSyntax :: String -> IO String +checkSyntax file = do + (_,_,herr,_) <- runInteractiveProcess "ghc" ["--make","-Wall",file] Nothing Nothing + refine <$> hGetContents herr + where + refine = unfoldLines start . map (dropWhile isSpace) . filter (/="") . lines + start = (file `isPrefixOf`) + +unfoldLines :: (String -> Bool) -> [String] -> String +unfoldLines p = drop 1 . unfold + where + unfold [] = "\n" + unfold (l:ls) + | p l = ('\n':l) ++ unfold ls + | otherwise = l ++ " " ++ unfold ls diff --git a/GHCMod.hs b/GHCMod.hs index c824e4d..ceba02b 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -1,25 +1,27 @@ module Main where +import Browse +import Check +import Control.Applicative import Control.Exception hiding (try) -import Data.Char import Data.List -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Parser hiding (parse) -import Language.Haskell.Exts.Syntax +import List import Prelude hiding (catch) import System.Console.GetOpt -import System.Environment +import System.Directory +import System.Environment (getArgs) +import System.FilePath import System.IO -import System.Process -import Text.ParserCombinators.Parsec +import System.Posix.Env ---------------------------------------------------------------- usage :: String -usage = "ghc-mod version 0.1.0\n" +usage = "ghc-mod version 0.2.0\n" ++ "Usage:\n" ++ "\t ghc-mod list\n" ++ "\t ghc-mod browse \n" + ++ "\t ghc-mod check \n" ++ "\t ghc-mod help\n" ---------------------------------------------------------------- @@ -41,105 +43,39 @@ 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) -> error $ concat errs ++ usageInfo usage argspec ---------------------------------------------------------------- main :: IO () main = flip catch handler $ do args <- getArgs + setPath let (opt,cmdArg) = parseArgs argspec args transform = if optToLisp opt then toLisp else toPlain - ll <- case cmdArg !! 0 of - cmd | cmd == "browse" -> browseModule $ cmdArg !! 1 - | cmd == "list" -> listModules - _ -> error usage - putStr $ transform $ nub $ sort $ ll + refine = transform . nub . sort + case cmdArg !! 0 of + cmd | cmd == "browse" -> refine <$> browseModule (cmdArg !! 1) >>= putStr + | cmd == "list" -> refine <$> listModules >>= putStr + | cmd == "check" -> checkSyntax (cmdArg !! 1) >>= putStr + _ -> error usage + hFlush stdout where handler :: ErrorCall -> IO () handler _ = putStr usage ----------------------------------------------------------------- - -browseModule :: String -> IO [String] -browseModule mname = do - xs <- getSyntax mname - let ys = preprocess xs - return $ parseSyntax ys - -getSyntax :: String -> IO String -getSyntax mname = do - (inp,out,_,_) <- runInteractiveProcess "ghci" [] 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 --- e -> error $ show e - _ -> [] +setPath :: IO () +setPath = do + home <- getHomeDirectory + mpath <- getEnv "PATH" + let path = maybe "/usr/bin:/bin" id mpath + newpath = "/usr/local/bin:/opt/local/bin:" + ++ (home ".cabal/bin") ++ ":" + ++ (home "bin") ++ ":" + ++ path + setEnv "PATH" newpath True ---------------------------------------------------------------- - -listModules :: IO [String] -listModules = do - cs <- getDump - return $ exposedModules cs - -getDump :: IO String -getDump = do - (_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing - hGetContents hout - -exposedModules :: String -> [String] -exposedModules cs = let 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 - in filter (\x -> not ("GHC" `isPrefixOf` x)) $ concatMap words ss - -values :: String -> [String] -> [String] -values tag ls = let len = length tag - fs = filter (tag `isPrefixOf`) ls - in map (drop len) fs - ----------------------------------------------------------------- - -unfoldLines :: String -> [String] -unfoldLines xs = self xs - 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'' - toLisp :: [String] -> String toLisp ms = "(" ++ unwords quoted ++ ")\n" where @@ -148,87 +84,3 @@ toLisp ms = "(" ++ unwords quoted ++ ")\n" toPlain :: [String] -> String toPlain = unlines - ----------------------------------------------------------------- - -preprocess :: String -> String -preprocess cs = case parse remove "remove" cs of - Right a -> a - Left e -> error $ show e - -modName :: Parser String -modName = do c <- oneOf ['A'..'Z'] - cs <- many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#" - return $ c:cs - -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 = do ms <- modName - char '.' - return $ ms ++ ['.'] - -ghcName :: Parser String -ghcName = do keyword - try sep <|> end - where - sep = do - ws <- sepBy1 anyName (char '.') - return $ last ws - end = do - endBy1 anyName (char '.') - return "" - -nonGhcName :: Parser String -nonGhcName = do c <- anyChar -- making this func non-empty - cs <- manyBefore anyChar keyword - return $ c:cs - -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 - ----------------------------------------------------------------- - -identifiers :: Module -> [String] -identifiers (Module _ _ _ _ _ _ x) = filter hid $ concatMap decl x - 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 diff --git a/List.hs b/List.hs new file mode 100644 index 0000000..d4f5c8b --- /dev/null +++ b/List.hs @@ -0,0 +1,54 @@ +module List (listModules) where + +import Control.Applicative +import Data.Char +import Data.List +import System.IO +import System.Process + +---------------------------------------------------------------- + +listModules :: IO [String] +listModules = exposedModules <$> getDump + +getDump :: IO String +getDump = do + (_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["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 + +---------------------------------------------------------------- + +unfoldLines :: String -> [String] +unfoldLines xs = self xs + 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'' diff --git a/elisp/Makefile b/elisp/Makefile index 14fb845..25f065d 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,7 +1,6 @@ -SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el +SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el EMACS = emacs - TEMPFILE = temp.el all: $(TEMPFILE) ghc.el diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index a5fc466..40b784b 100644 --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -66,8 +66,7 @@ (lambda () (let ((msg (mapconcat 'identity (cons ghc-module-command args) " "))) (message "Executing \"%s\"..." msg) - (apply 'call-process-shell-command - ghc-module-command nil t nil (cons "-l" args)) + (apply 'call-process ghc-module-command nil t nil (cons "-l" args)) (message "Executing \"%s\"...done" msg)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el new file mode 100644 index 0000000..648dcc0 --- /dev/null +++ b/elisp/ghc-flymake.el @@ -0,0 +1,23 @@ +(require 'flymake) + +(defvar 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 + '("^\\(.*\\.l?hs\\):\\([0-9]+\\):\\([0-9]+\\):\\(.+\\)" 1 2 3 4)) + +(add-to-list 'flymake-allowed-file-name-masks + ghc-flymake-allowed-file-name-masks) + +(add-to-list 'flymake-err-line-patterns + ghc-flymake-err-line-patterns) + +(defun ghc-flymake-init () + (let* ((temp-file (flymake-init-create-temp-buffer-copy + 'flymake-create-temp-inplace)) + (local-file (file-relative-name + temp-file + (file-name-directory buffer-file-name)))) + (list "ghc-mod" (list "check" local-file)))) + +(provide 'ghc-flymake) \ No newline at end of file diff --git a/elisp/ghc.el b/elisp/ghc.el index e7f6f01..7105821 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -14,11 +14,14 @@ ;;; Code: -(defvar ghc-version "0.1") +(defvar ghc-version "0.2.0") + +;; (eval-when-compile +;; (require 'haskell-mode)) -;; (require 'haskell-mode) (require 'ghc-comp) (require 'ghc-doc) +(require 'ghc-flymake) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -28,6 +31,10 @@ (defvar ghc-completion-key "\e\t") (defvar ghc-document-key "\e\C-d") (defvar ghc-import-key "\e\C-m") +(defvar ghc-check-key "\e\C-c") +(defvar ghc-previous-key "\e\C-p") +(defvar ghc-next-key "\e\C-n") +(defvar ghc-help-key "\e?") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -41,5 +48,11 @@ (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-check-key 'flymake-start-syntax-check) + (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 'flymake-display-err-menu-for-current-line) (ghc-comp-init) (setq ghc-initialized t))) + +(provide 'ghc) \ No newline at end of file diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c1970ac..2f944ab 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -21,9 +21,11 @@ Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el Executable ghc-mod Main-Is: GHCMod.hs + Other-Modules: List Browse GHC-Options: -Wall Build-Depends: base >= 4.0 && < 10, - parsec, process, haskell-src-exts + parsec, process, haskell-src-exts, + unix, directory, filepath Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git