125 lines
3.6 KiB
Haskell
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
|