Using GHC API for browse!

Browse.hs

@@ -1,124 +1,30 @@
 module Browse (browseModule) where
 
-import Control.Applicative hiding ((<|>), many)
+import Control.Applicative
 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 DynFlags
+import GHC
+import GHC.Paths (libdir)
+import Name
 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
+browseModule opt mdlName = convert opt . validate <$> browse mdlName
   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
+    validate = sort . filter (isAlpha.head)
 
-parseSyntax :: String -> [String]
-parseSyntax xs = do
-    let mode = defaultParseMode { extensions = NewQualifiedOperators : ExplicitForall : glasgowExts }
-        res = parseModuleWithMode mode xs
-    case res of
-      ParseOk x       -> identifiers x
-      _               -> []
+browse :: String -> IO [String]
+browse mdlName = withGHCAPI (maybeNamesToStrings <$> lookupModuleInfo)
 
-
-----------------------------------------------------------------
-
-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 ()
+    lookupModuleInfo = lookupModule (mkModuleName mdlName) Nothing >>= getModuleInfo
+    maybeNamesToStrings = maybe [] (map getOccString . modInfoExports)
 
-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
+withGHCAPI :: Ghc a -> IO a
+withGHCAPI body = defaultErrorHandler defaultDynFlags $
+    runGhc (Just libdir) $ do
+        getSessionDynFlags >>= setSessionDynFlags
+        body

ghc-mod.cabal

@@ -28,7 +28,7 @@ Executable ghc-mod
     GHC-Options:        -Wall -fno-warn-unused-do-bind
   else
     GHC-Options:        -Wall
-  Build-Depends:        base >= 4.0 && < 5, ghc,
+  Build-Depends:        base >= 4.0 && < 5, ghc, ghc-paths,
                         parsec >= 3, process, haskell-src-exts,
                         directory, filepath
 Source-Repository head