Merge remote-tracking branch 'kazu/master'

This commit is contained in:
Alejandro Serrano 2014-07-17 06:59:29 +02:00
commit b21fa674ea
6 changed files with 144 additions and 63 deletions

View File

@ -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

View File

@ -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

View File

@ -1,10 +1,6 @@
module Language.Haskell.GhcMod.Ghc (
-- * 'SymMdlDb'
Symbol
, SymMdlDb
, getSymMdlDb
, lookupSym
, lookupSym'
module Language.Haskell.GhcMod.Find
) where
import Language.Haskell.GhcMod.Find

View File

@ -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

View File

@ -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

View File

@ -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