Merge remote-tracking branch 'kazu/master'
This commit is contained in:
Alejandro Serrano
commit
b21fa674ea
@ -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
|
||||
|
||||
@ -131,7 +131,7 @@ Executable ghc-modi
|
||||
Default-Language: Haskell2010
|
||||
Main-Is: GHCModi.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
GHC-Options: -Wall
|
||||
GHC-Options: -Wall -threaded
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
HS-Source-Dirs: src
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
|
||||
@ -10,6 +10,7 @@ import qualified Control.Exception as E
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Ghc
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Paths_ghc_mod
|
||||
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
|
||||
@ -130,6 +131,7 @@ main = flip E.catches handlers $ do
|
||||
"lint" -> nArgs 1 $ withFile lint cmdArg1
|
||||
"root" -> rootInfo
|
||||
"doc" -> nArgs 1 $ pkgDoc cmdArg1
|
||||
"dumpsym" -> dumpSymbol
|
||||
"boot" -> boot
|
||||
"version" -> return progVersion
|
||||
"help" -> return $ O.usageInfo usage argspec
|
||||
|
||||
@ -31,7 +31,6 @@ import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import Exception (ghandle)
|
||||
import GHC (GhcMonad)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod
|
||||
@ -101,7 +100,7 @@ main = E.handle cmdHandler $
|
||||
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
|
||||
setCurrentDirectory rootdir
|
||||
mvar <- liftIO newEmptyMVar
|
||||
void $ forkIO $ runGhcModT opt $ setupDB mvar
|
||||
void $ forkIO $ setupDB mvar
|
||||
runGhcModT opt $ loop S.empty mvar
|
||||
where
|
||||
-- this is just in case.
|
||||
@ -116,15 +115,12 @@ replace (x:xs) = x : replace xs
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
setupDB :: IOish m => MVar SymMdlDb -> GhcModT m ()
|
||||
setupDB mvar = ghandle handler $ do
|
||||
liftIO . putMVar mvar =<< getSymMdlDb
|
||||
where
|
||||
handler (SomeException _) = return () -- fixme: put emptyDb?
|
||||
setupDB :: MVar SymbolDb -> IO ()
|
||||
setupDB mvar = getSymbolDb >>= putMVar mvar
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
loop :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m ()
|
||||
loop :: IOish m => Set FilePath -> MVar SymbolDb -> GhcModT m ()
|
||||
loop set mvar = do
|
||||
cmdArg <- liftIO getLine
|
||||
let (cmd,arg') = break (== ' ') cmdArg
|
||||
@ -193,12 +189,12 @@ isSameMainFile file (Just x)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
findSym :: IOish m => Set FilePath -> String -> MVar SymMdlDb
|
||||
findSym :: IOish m => Set FilePath -> String -> MVar SymbolDb
|
||||
-> GhcModT m (String, Bool, Set FilePath)
|
||||
findSym set sym mvar = do
|
||||
db <- liftIO $ readMVar mvar
|
||||
opt <- options
|
||||
let ret = lookupSym' opt sym db
|
||||
let ret = lookupSymbol opt sym db
|
||||
return (ret, True, set)
|
||||
|
||||
lintStx :: IOish m => Set FilePath
|
||||
|
||||
Loading…
Reference in New Issue
Block a user