introducing -i, -g, and -p.

This commit is contained in:
Kazu Yamamoto 2010-03-11 22:39:07 +09:00
parent 36fee672f3
commit ed5d50b6f9
8 changed files with 83 additions and 84 deletions

View File

@ -1,5 +1,6 @@
module Browse (browseModule) where
import Control.Applicative hiding ((<|>), many)
import Data.Char
import Data.List
import Language.Haskell.Exts.Extension
@ -7,19 +8,18 @@ import Language.Haskell.Exts.Parser hiding (parse)
import Language.Haskell.Exts.Syntax
import System.IO
import System.Process
import Text.ParserCombinators.Parsec
import Text.Parsec
import Text.Parsec.String
import Param
----------------------------------------------------------------
browseModule :: String -> IO [String]
browseModule mname = do
xs <- getSyntax mname
let ys = preprocess xs
return $ parseSyntax ys
browseModule :: Options -> String -> IO String
browseModule opt mname = convert opt . nub . sort . parseSyntax . preprocess <$> getSyntax opt mname
getSyntax :: String -> IO String
getSyntax mname = do
(inp,out,_,_) <- runInteractiveProcess "ghci" [] Nothing Nothing
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"
@ -42,7 +42,6 @@ parseSyntax xs = do
res = parseModuleWithMode mode xs
case res of
ParseOk x -> identifiers x
-- e -> error $ show e
_ -> []
@ -54,17 +53,17 @@ preprocess cs = case parse remove "remove" cs of
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
modName = (:) <$> (oneOf ['A'..'Z'])
<*> (many . oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#")
anyName :: Parser String
anyName = many1 $ oneOf $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'#"
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
anc = do
pos <- getPosition
s <- anchor
ss <- getInput
setInput $ s ++ ss
@ -72,28 +71,22 @@ manyBefore p anchor = manyTill p (eof <|> try anc)
return ()
keyword :: Parser String
keyword = do ms <- modName
char '.'
return $ ms ++ ['.']
keyword = (++) <$> modName <*> string "."
ghcName :: Parser String
ghcName = do keyword
ghcName = do
keyword
try sep <|> end
where
sep = do
ws <- sepBy1 anyName (char '.')
return $ last ws
end = do
endBy1 anyName (char '.')
return ""
sep = last <$> sepBy1 anyName (char '.')
end = "" <$ endBy1 anyName (char '.')
nonGhcName :: Parser String
nonGhcName = do c <- anyChar -- making this func non-empty
cs <- manyBefore anyChar keyword
return $ c:cs
nonGhcName = (:) <$> anyChar <*> manyBefore anyChar keyword
remove :: Parser String
remove = do l1 <- try ghcName <|> return ""
remove = do
l1 <- try ghcName <|> return ""
l2 <- nonGhcName
ll <- many (do x <- ghcName
y <- nonGhcName

View File

@ -3,21 +3,23 @@ module Check (checkSyntax) where
import Control.Applicative
import Data.Char
import Data.List
import Param
import System.IO
import System.Process
----------------------------------------------------------------
checkSyntax :: String -> IO String
checkSyntax file = do
(_,_,herr,_) <- runInteractiveProcess "ghc" ["--make","-Wall",file] Nothing Nothing
checkSyntax :: Options -> String -> IO String
checkSyntax opt file = do
(_,_,herr,_) <- runInteractiveProcess (ghc opt) ["--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
unfoldLines _ [] = ""
unfoldLines p (x:xs) = x ++ unfold xs
where
unfold [] = "\n"
unfold (l:ls)

View File

@ -2,17 +2,13 @@ module Main where
import Browse
import Check
import Control.Applicative
import Control.Exception hiding (try)
import Data.List
import List
import Param
import Prelude hiding (catch)
import System.Console.GetOpt
import System.Directory
import System.Environment (getArgs)
import System.FilePath
import System.IO
import System.Posix.Env
----------------------------------------------------------------
@ -26,17 +22,26 @@ usage = "ghc-mod version 0.2.0\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"
}
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"
]
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
@ -50,31 +55,17 @@ parseArgs spec argv
main :: IO ()
main = flip catch handler $ do
args <- getArgs
setPath
let (opt,cmdArg) = parseArgs argspec args
transform = if optToLisp opt then toLisp else toPlain
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
res <- case cmdArg !! 0 of
"browse" -> browseModule opt (cmdArg !! 1)
"list" -> listModules opt
"check" -> checkSyntax opt (cmdArg !! 1)
_ -> error usage
hFlush stdout
putStr res
where
handler :: ErrorCall -> IO ()
handler _ = putStr usage
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
----------------------------------------------------------------
toLisp :: [String] -> String
toLisp ms = "(" ++ unwords quoted ++ ")\n"

11
List.hs
View File

@ -3,17 +3,18 @@ module List (listModules) where
import Control.Applicative
import Data.Char
import Data.List
import Param
import System.IO
import System.Process
----------------------------------------------------------------
listModules :: IO [String]
listModules = exposedModules <$> getDump
listModules :: Options -> IO String
listModules opt = convert opt . nub . sort . exposedModules <$> getDump opt
getDump :: IO String
getDump = do
(_,hout,_,_) <- runInteractiveProcess "ghc-pkg" ["dump"] Nothing Nothing
getDump :: Options -> IO String
getDump opt = do
(_,hout,_,_) <- runInteractiveProcess (ghcPkg opt) ["dump"] Nothing Nothing
hGetContents hout
exposedModules :: String -> [String]

View File

@ -15,8 +15,6 @@
;;; Customize Variables
;;;
(defvar ghc-module-command "ghc-mod")
(defvar ghc-idle-timer-interval 30)
;; must be sorted
@ -66,7 +64,8 @@
(lambda ()
(let ((msg (mapconcat 'identity (cons ghc-module-command args) " ")))
(message "Executing \"%s\"..." msg)
(apply 'call-process 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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

View File

@ -18,6 +18,7 @@
(local-file (file-relative-name
temp-file
(file-name-directory buffer-file-name))))
(list "ghc-mod" (list "check" local-file))))
(list "ghc-mod" (append (ghc-module-command-args)
(list "check" local-file)))))
(provide 'ghc-flymake)

View File

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

View File

@ -24,7 +24,7 @@ Executable ghc-mod
Other-Modules: List Browse
GHC-Options: -Wall
Build-Depends: base >= 4.0 && < 10,
parsec, process, haskell-src-exts,
parsec >= 3, process, haskell-src-exts,
unix, directory, filepath
Source-Repository head
Type: git