diff --git a/Browse.hs b/Browse.hs new file mode 100644 --- /dev/null +++ b/Browse.hs @@ -0,0 +1,124 @@ +module Browse (browseModule) where + +import Control.Applicative hiding ((<|>), many) +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 + +---------------------------------------------------------------- + +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 + 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 + +---------------------------------------------------------------- + +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 --- /dev/null +++ b/Check.hs @@ -0,0 +1,44 @@ +module Check (checkSyntax) where + +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 + +---------------------------------------------------------------- + +checkSyntax :: Options -> String -> IO String +checkSyntax opt file = do + makeDirectory (outDir opt) + (_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--make","-Wall",file,"-outputdir","dist/flymake","-o","dist/flymake/a.out"] Nothing Nothing + refine <$> hGetContents herr + where + refine = unfoldLines start . map (dropWhile isSpace) . filter (/="") . lines + start = (file `isPrefixOf`) + +unfoldLines :: (String -> Bool) -> [String] -> String +unfoldLines _ [] = "" +unfoldLines p (x:xs) = x ++ unfold xs + where + unfold [] = "\n" + unfold (l:ls) + | p l = ('\n':l) ++ unfold ls + | otherwise = (' ' :l) ++ unfold ls + +---------------------------------------------------------------- + +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 diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -1,47 +1,58 @@ module Main where +import Browse +import Check 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 Param import Prelude hiding (catch) import System.Console.GetOpt -import System.Environment +import System.Environment (getArgs) import System.IO -import System.Process -import Text.ParserCombinators.Parsec ---------------------------------------------------------------- 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" ---------------------------------------------------------------- -data Options = Options { optToLisp :: Bool - } deriving Show - defaultOptions :: Options -defaultOptions = Options { optToLisp = False +defaultOptions = Options { convert = toPlain + , ghc = "ghc" + , ghci = "ghci" + , ghcPkg = "ghc-pkg" + , outDir = "dist/flymake" } argspec :: [OptDescr (Options -> Options)] argspec = [ Option ['l'] ["tolisp"] - (NoArg (\opts -> opts { optToLisp = True })) + (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" ] 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 ---------------------------------------------------------------- @@ -49,97 +60,17 @@ main = flip catch handler $ do args <- getArgs 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 + res <- case cmdArg !! 0 of + "browse" -> browseModule opt (cmdArg !! 1) + "list" -> listModules opt + "check" -> checkSyntax opt (cmdArg !! 1) + _ -> error usage + putStr res 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 - _ -> [] - ----------------------------------------------------------------- - -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 +79,3 @@ 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 --- /dev/null +++ b/List.hs @@ -0,0 +1,55 @@ +module List (listModules) where + +import Control.Applicative +import Data.Char +import Data.List +import Param +import System.IO +import System.Process + +---------------------------------------------------------------- + +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 + +---------------------------------------------------------------- + +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/Param.hs b/Param.hs new file mode 100644 --- /dev/null +++ b/Param.hs @@ -0,0 +1,9 @@ +module Param where + +data Options = Options { convert :: [String] -> String + , ghc :: FilePath + , ghci :: FilePath + , ghcPkg :: FilePath + , outDir :: FilePath + } + diff --git a/elisp/Makefile b/elisp/Makefile --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,6 +1,5 @@ -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 diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -15,8 +15,6 @@ ;;; Customize Variables ;;; -(defvar ghc-module-command "ghc-mod") - (defvar ghc-idle-timer-interval 30) ;; must be sorted @@ -66,8 +64,8 @@ (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 + (append '("-l") (ghc-module-command-args) args)) (message "Executing \"%s\"...done" msg)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -28,7 +28,9 @@ (defun ghc-resolve-document-path (pkg) (with-temp-buffer (call-process "ghc-pkg" nil t nil "field" pkg "haddock-html") - (goto-char (point-min)) + (goto-char (point-max)) + (forward-line -1) + (beginning-of-line) (when (looking-at "^haddock-html: \\([^ \n]+\\)$") (match-string-no-properties 1)))) diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el new file mode 100644 --- /dev/null +++ b/elisp/ghc-flymake.el @@ -0,0 +1,32 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-flymake.el +;;; + +;; Author: Kazu Yamamoto +;; Created: Mar 12, 2010 + +;;; Code: + +(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 ((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))))) + +(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 @@ -49,4 +49,16 @@ (defun ghc-read-module-name (def) (read-from-minibuffer "Module name: " def ghc-input-map)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)) + (provide 'ghc-func) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -11,14 +11,19 @@ ;; ;; (autoload 'ghc-init "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) +;; Or +;; (add-hook 'haskell-mode-hook (lambda () (ghc-init) (flymake-mode))) ;;; Code: -(defvar ghc-version "0.1") +(defvar ghc-version "0.2.0") -;; (require 'haskell-mode) +;; (eval-when-compile +;; (require 'haskell-mode)) + (require 'ghc-comp) (require 'ghc-doc) +(require 'ghc-flymake) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -28,6 +33,9 @@ (defvar ghc-completion-key "\e\t") (defvar ghc-document-key "\e\C-d") (defvar ghc-import-key "\e\C-m") +(defvar ghc-previous-key "\ep") +(defvar ghc-next-key "\en") +(defvar ghc-help-key "\e?") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -41,5 +49,10 @@ (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-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) 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.1.0 +Version: 0.2.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -10,6 +10,7 @@ and a Haskell command, "ghc-mod". "ghc*.el" enable completion of Haskell symbols on Emacs. + Flymake is also integrated. "ghc-mod" is a backend of "ghc*.el". It lists up all installed modules or extracts names of functions, classes, @@ -19,11 +20,14 @@ Build-Type: Simple Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el + ghc-flymake.el Executable ghc-mod Main-Is: GHCMod.hs + Other-Modules: List Browse Check Param GHC-Options: -Wall Build-Depends: base >= 4.0 && < 10, - parsec, process, haskell-src-exts + parsec >= 3, process, haskell-src-exts, + directory, filepath Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git