diff --git a/Browse.hs b/Browse.hs index 893349d..b5fd130 100644 --- a/Browse.hs +++ b/Browse.hs @@ -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,51 +53,45 @@ 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 - s <- anchor - ss <- getInput - setInput $ s ++ ss - setPosition pos - return () + anc = do + pos <- getPosition + s <- anchor + ss <- getInput + setInput $ s ++ ss + setPosition pos + return () keyword :: Parser String -keyword = do ms <- modName - char '.' - return $ ms ++ ['.'] +keyword = (++) <$> modName <*> string "." ghcName :: Parser String -ghcName = do keyword - try sep <|> end +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 "" - l2 <- nonGhcName - ll <- many (do x <- ghcName - y <- nonGhcName - return $ x ++ y) - return $ concat $ l1 : l2 : ll +remove = do + l1 <- try ghcName <|> return "" + l2 <- nonGhcName + ll <- many (do x <- ghcName + y <- nonGhcName + return $ x ++ y) + return $ concat $ l1 : l2 : ll ---------------------------------------------------------------- diff --git a/Check.hs b/Check.hs index 438eab2..308551f 100644 --- a/Check.hs +++ b/Check.hs @@ -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) diff --git a/GHCMod.hs b/GHCMod.hs index ceba02b..5a08332 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -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 - _ -> error usage - hFlush stdout + 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 -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" diff --git a/List.hs b/List.hs index d4f5c8b..8f082ef 100644 --- a/List.hs +++ b/List.hs @@ -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] diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index 40b784b..de336af 100644 --- 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,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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el index 648dcc0..c6d78d3 100644 --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -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) \ No newline at end of file diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el index 59b4634..8f7639c 100644 --- 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/ghc-mod.cabal b/ghc-mod.cabal index 2f944ab..bede029 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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