132 lines
3.8 KiB
Haskell
132 lines
3.8 KiB
Haskell
module Browse (browseModule) where
|
|
|
|
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.ParserCombinators.Parsec
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|
|
_ -> []
|
|
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|