ghc-mod/Browse.hs
2010-03-11 22:39:07 +09:00

125 lines
3.6 KiB
Haskell

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