Merge remote-tracking branch 'kazu/master'
This commit is contained in:
Alejandro Serrano
@@ -1,7 +1,6 @@
|
||||
module Language.Haskell.GhcMod.Browse (
|
||||
browse
|
||||
, browseAll)
|
||||
where
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
@@ -12,7 +11,7 @@ import Exception (ghandle)
|
||||
import FastString (mkFastString)
|
||||
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified)
|
||||
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
@@ -135,20 +134,3 @@ removeForAlls' ty (Just (pre, ftype))
|
||||
|
||||
showOutputable :: Outputable a => DynFlags -> a -> String
|
||||
showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Browsing all functions in all system/user modules.
|
||||
browseAll :: IOish m => DynFlags -> GhcModT m [(String,String)]
|
||||
browseAll dflag = do
|
||||
ms <- G.packageDbModules True
|
||||
is <- mapM G.getModuleInfo ms
|
||||
return $ concatMap (toNameModule dflag) (zip ms is)
|
||||
|
||||
toNameModule :: DynFlags -> (G.Module, Maybe ModuleInfo) -> [(String,String)]
|
||||
toNameModule _ (_,Nothing) = []
|
||||
toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names
|
||||
where
|
||||
mdl = G.moduleNameString (G.moduleName m)
|
||||
names = G.modInfoExports inf
|
||||
toStr = showOneLine dflag styleUnqualified . ppr
|
||||
|
||||
@@ -1,57 +1,162 @@
|
||||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Find where
|
||||
module Language.Haskell.GhcMod.Find (
|
||||
Symbol
|
||||
, SymbolDb
|
||||
, getSymbolDb
|
||||
, lookupSymbol
|
||||
, dumpSymbol
|
||||
, findSymbol
|
||||
) where
|
||||
|
||||
import Config (cProjectVersion,cTargetPlatformString)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (handle, SomeException(..))
|
||||
import Control.Monad (when, void)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sort)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import DynFlags (DynFlags(..), systemPackageConfig)
|
||||
import Exception (handleIO)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Browse (browseAll)
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Name (getOccString)
|
||||
import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO
|
||||
import System.Process (readProcess)
|
||||
|
||||
#ifndef MIN_VERSION_containers
|
||||
#define MIN_VERSION_containers(x,y,z) 1
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_containers(0,5,0)
|
||||
import Control.DeepSeq (force)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
#else
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
#endif
|
||||
import Control.Applicative ((<$>))
|
||||
|
||||
-- | Type of key for `SymMdlDb`.
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Type of key for `SymbolDb`.
|
||||
type Symbol = String
|
||||
type Db = Map Symbol [ModuleString]
|
||||
-- | Database from 'Symbol' to modules.
|
||||
newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString])
|
||||
newtype SymbolDb = SymbolDb Db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
symbolCache :: String
|
||||
symbolCache = "ghc-mod.cache"
|
||||
|
||||
packageCache :: String
|
||||
packageCache = "package.cache"
|
||||
|
||||
packageConfDir :: String
|
||||
packageConfDir = "package.conf.d"
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Finding modules to which the symbol belong.
|
||||
findSymbol :: IOish m => Symbol -> GhcModT m String
|
||||
findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb
|
||||
findSymbol sym = convert' =<< lookupSymbol' sym <$> liftIO getSymbolDb
|
||||
|
||||
-- | Creating 'SymMdlDb'.
|
||||
getSymMdlDb :: IOish m => GhcModT m SymMdlDb
|
||||
getSymMdlDb = do
|
||||
sm <- G.getSessionDynFlags >>= browseAll
|
||||
#if MIN_VERSION_containers(0,5,0)
|
||||
let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm
|
||||
!m = force $ M.fromList sms
|
||||
#else
|
||||
let !sms = map tieup $ groupBy ((==) `on` fst) $ sort sm
|
||||
!m = M.fromList sms
|
||||
#endif
|
||||
return (SymMdlDb m)
|
||||
lookupSymbol' :: Symbol -> SymbolDb -> [ModuleString]
|
||||
lookupSymbol' sym (SymbolDb db) = fromMaybe [] (M.lookup sym db)
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to find modules.
|
||||
lookupSymbol :: Options -> Symbol -> SymbolDb -> String
|
||||
lookupSymbol opt sym db = convert opt $ lookupSymbol' sym db
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
-- | Creating 'SymbolDb'.
|
||||
getSymbolDb :: IO SymbolDb
|
||||
getSymbolDb = SymbolDb <$> loadSymbolDb
|
||||
|
||||
loadSymbolDb :: IO Db
|
||||
loadSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
|
||||
file <- chop <$> readProcess "ghc-mod" ["dumpsym"] []
|
||||
M.fromAscList . map conv . lines <$> readFile file
|
||||
where
|
||||
conv :: String -> (Symbol,[ModuleString])
|
||||
conv = read
|
||||
chop "" = ""
|
||||
chop xs = init xs
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- used 'ghc-mod dumpsym'
|
||||
|
||||
getPath :: IOish m => GhcModT m (Maybe String)
|
||||
getPath = do
|
||||
df <- G.getSessionDynFlags
|
||||
stack <- cradlePkgDbStack . gmCradle <$> ask
|
||||
case filter (GlobalDb /=) stack of
|
||||
[] -> return Nothing
|
||||
u:_ -> liftIO $ resolvePackageDb df u
|
||||
|
||||
dumpSymbol :: IOish m => GhcModT m String
|
||||
dumpSymbol = do
|
||||
mdir <- getPath
|
||||
ret <- case mdir of
|
||||
Nothing -> return ""
|
||||
Just dir -> do
|
||||
let cache = dir </> symbolCache
|
||||
pkgdb = dir </> packageCache
|
||||
do -- fixme: bracket
|
||||
create <- liftIO $ needToCreate cache pkgdb
|
||||
when create $ do
|
||||
sm <- getSymbol
|
||||
void . liftIO $ withFile cache WriteMode $ \hdl ->
|
||||
mapM (hPutStrLn hdl . show) sm
|
||||
return cache
|
||||
return $ ret ++ "\n"
|
||||
|
||||
needToCreate :: FilePath -> FilePath -> IO Bool
|
||||
needToCreate file1 file2 = do
|
||||
exist <- doesFileExist file1
|
||||
if not exist then
|
||||
return True
|
||||
else do
|
||||
m1 <- getModificationTime file1
|
||||
m2 <- getModificationTime file2
|
||||
return $ m1 <= m2 -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system/user modules.
|
||||
getSymbol :: IOish m => GhcModT m [(Symbol,[ModuleString])]
|
||||
getSymbol = do
|
||||
ms <- G.packageDbModules True
|
||||
let ns = map (G.moduleNameString . G.moduleName) ms
|
||||
is <- mapM G.getModuleInfo ms
|
||||
let symbols = concatMap toNameModule (zip is ns)
|
||||
return $ uniquefy symbols
|
||||
|
||||
toNameModule :: (Maybe G.ModuleInfo,ModuleString) -> [(Symbol,ModuleString)]
|
||||
toNameModule (Nothing,_) = []
|
||||
toNameModule (Just inf,mdlname) = map (\name -> (getOccString name, mdlname)) names
|
||||
where
|
||||
names = G.modInfoExports inf
|
||||
|
||||
uniquefy :: [(Symbol,ModuleString)] -> [(Symbol,[ModuleString])]
|
||||
uniquefy = map tieup . groupBy ((==) `on` fst) . sort
|
||||
where
|
||||
tieup x = (head (map fst x), map snd x)
|
||||
|
||||
-- | Looking up 'SymMdlDb' with 'Symbol' to find modules.
|
||||
lookupSym :: Symbol -> SymMdlDb -> [ModuleString]
|
||||
lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db)
|
||||
|
||||
lookupSym' :: Options -> Symbol -> SymMdlDb -> String
|
||||
lookupSym' opt sym db = convert opt $ lookupSym sym db
|
||||
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
||||
resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
|
||||
resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df)
|
||||
resolvePackageDb _ (PackageDb name) = return $ Just name
|
||||
resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do
|
||||
appdir <- getAppUserDataDirectory "ghc"
|
||||
let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
|
||||
pkgconf = dir </> packageConfDir
|
||||
exist <- doesDirectoryExist pkgconf
|
||||
return $ if exist then Just pkgconf else Nothing
|
||||
where
|
||||
[target_arch,_,target_os] = splitOn "-" cTargetPlatformString
|
||||
|
||||
@@ -1,10 +1,6 @@
|
||||
module Language.Haskell.GhcMod.Ghc (
|
||||
-- * 'SymMdlDb'
|
||||
Symbol
|
||||
, SymMdlDb
|
||||
, getSymMdlDb
|
||||
, lookupSym
|
||||
, lookupSym'
|
||||
-- * 'SymMdlDb'
|
||||
module Language.Haskell.GhcMod.Find
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Find
|
||||
|
||||
Reference in New Issue
Block a user