diff --git a/Browse.hs b/Browse.hs index c8bd066..15a0e04 100644 --- a/Browse.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 59d4178..28af463 100644 --- a/ghc-mod.cabal +++ b/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