ghc-mod/Browse.hs

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