From cee1b83daa0655b46eb462280eb5258bb582d137 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 16 Jul 2014 18:14:12 +0900 Subject: [PATCH] the first step to create SymbolDB via a file. --- Language/Haskell/GhcMod/Browse.hs | 22 +--- Language/Haskell/GhcMod/Find.hs | 161 +++++++++++++++++++++++++----- Language/Haskell/GhcMod/Ghc.hs | 8 +- ghc-mod.cabal | 2 +- src/GHCMod.hs | 2 + src/GHCModi.hs | 10 +- 6 files changed, 147 insertions(+), 58 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index aa0d1df..b29fefd 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index d414e40..bc9c001 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,57 +1,166 @@ {-# 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.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 = do + file <- chop <$> readProcess "ghc-mod" ["dumpsym"] [] + exist <- doesFileExist file -- False if file is "" + !db <- if exist then + M.fromAscList . map conv . lines <$> liftIO (readFile file) + else + return M.empty + return db + 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 diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 074a218..ce9b3e2 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9623b77..9a23d1e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 8424a3d..561aa86 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -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(..)) @@ -127,6 +128,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 diff --git a/src/GHCModi.hs b/src/GHCModi.hs index d67a58d..a60cdb4 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -116,15 +116,15 @@ replace (x:xs) = x : replace xs ---------------------------------------------------------------- -setupDB :: IOish m => MVar SymMdlDb -> GhcModT m () +setupDB :: IOish m => MVar SymbolDb -> GhcModT m () setupDB mvar = ghandle handler $ do - liftIO . putMVar mvar =<< getSymMdlDb + liftIO (putMVar mvar =<< getSymbolDb) where handler (SomeException _) = return () -- fixme: put emptyDb? ---------------------------------------------------------------- -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 @@ -192,12 +192,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