integrating flymake.

This commit is contained in:
Kazu Yamamoto 2010-03-11 19:03:17 +09:00
parent f1a0e079db
commit 1e445097b7
9 changed files with 282 additions and 184 deletions

131
Browse.hs Normal file
View File

@ -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

25
Check.hs Normal file
View File

@ -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

204
GHCMod.hs
View File

@ -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 <module>\n"
++ "\t ghc-mod check <HaskellFile>\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
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
putStr $ transform $ nub $ sort $ ll
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

54
List.hs Normal file
View File

@ -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''

View File

@ -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

View File

@ -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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

23
elisp/ghc-flymake.el Normal file
View File

@ -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)

View File

@ -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)

View File

@ -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