ghc-mod-0.1.0: GHCMod.hs
module Main where
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 Prelude hiding (catch)
import System.Console.GetOpt
import System.Environment
import System.IO
import System.Process
import Text.ParserCombinators.Parsec
----------------------------------------------------------------
usage :: String
usage = "ghc-mod version 0.1.0\n"
++ "Usage:\n"
++ "\t ghc-mod list\n"
++ "\t ghc-mod browse <module>\n"
++ "\t ghc-mod help\n"
----------------------------------------------------------------
data Options = Options { optToLisp :: Bool
} deriving Show
defaultOptions :: Options
defaultOptions = Options { optToLisp = False
}
argspec :: [OptDescr (Options -> Options)]
argspec = [ Option ['l'] ["tolisp"]
(NoArg (\opts -> opts { optToLisp = True }))
"print as a list of Lisp"
]
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)
----------------------------------------------------------------
main :: IO ()
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
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
quote x = "\"" ++ x ++ "\""
quoted = map quote ms
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