163 lines
5.2 KiB
Haskell
163 lines
5.2 KiB
Haskell
{-# LANGUAGE CPP, BangPatterns #-}
|
|
|
|
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.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 Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
#else
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as M
|
|
#endif
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Type of key for `SymbolDb`.
|
|
type Symbol = String
|
|
type Db = Map Symbol [ModuleString]
|
|
-- | Database from 'Symbol' to modules.
|
|
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' =<< lookupSymbol' sym <$> liftIO getSymbolDb
|
|
|
|
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)
|
|
|
|
--- 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
|