ghc-mod 0.1.0 → 0.2.0
raw patch · 12 files changed
+335/−196 lines, 12 filesdep +directorydep +filepathdep ~parsec
Dependencies added: directory, filepath
Dependency ranges changed: parsec
Files
- Browse.hs +124/−0
- Check.hs +44/−0
- GHCMod.hs +32/−185
- List.hs +55/−0
- Param.hs +9/−0
- elisp/Makefile +1/−2
- elisp/ghc-comp.el +2/−4
- elisp/ghc-doc.el +3/−1
- elisp/ghc-flymake.el +32/−0
- elisp/ghc-func.el +12/−0
- elisp/ghc.el +15/−2
- ghc-mod.cabal +6/−2
+ Browse.hs view
@@ -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
+ Check.hs view
@@ -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
GHCMod.hs view
@@ -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 <module>\n"+ ++ "\t ghc-mod check <HaskellFile>\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
+ List.hs view
@@ -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''
+ Param.hs view
@@ -0,0 +1,9 @@+module Param where++data Options = Options { convert :: [String] -> String+ , ghc :: FilePath+ , ghci :: FilePath+ , ghcPkg :: FilePath+ , outDir :: FilePath+ }+
elisp/Makefile view
@@ -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
elisp/ghc-comp.el view
@@ -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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-doc.el view
@@ -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))))
+ elisp/ghc-flymake.el view
@@ -0,0 +1,32 @@+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; ghc-flymake.el+;;;++;; Author: Kazu Yamamoto <Kazu@Mew.org>+;; 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)
elisp/ghc-func.el view
@@ -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)
elisp/ghc.el view
@@ -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)
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 0.1.0+Version: 0.2.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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