the first step to create SymbolDB via a file.

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

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'.
+lookupSymbol' :: Symbol -> SymbolDb -> [ModuleString]
-getSymMdlDb :: IOish m => GhcModT m SymMdlDb
+lookupSymbol' sym (SymbolDb db) = fromMaybe [] (M.lookup sym db)
-getSymMdlDb = do
+
-    sm <- G.getSessionDynFlags >>= browseAll
+-- | Looking up 'SymbolDb' with 'Symbol' to find modules.
-#if MIN_VERSION_containers(0,5,0)
+lookupSymbol :: Options -> Symbol -> SymbolDb -> String
-    let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm
+lookupSymbol opt sym db = convert opt $ lookupSymbol' sym db
-        !m = force $ M.fromList sms
+
-#else
+---------------------------------------------------------------
-    let !sms = map tieup $ groupBy ((==) `on` fst) $ sort sm
+
-        !m = M.fromList sms
+-- | Creating 'SymbolDb'.
-#endif
+getSymbolDb :: IO SymbolDb
-    return (SymMdlDb m)
+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.
+--- Copied from ghc module `Packages' unfortunately it's not exported :/
-lookupSym :: Symbol -> SymMdlDb -> [ModuleString]
+resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
-lookupSym sym (SymMdlDb db) = fromMaybe [] (M.lookup sym db)
+resolvePackageDb df GlobalDb         = return $ Just (systemPackageConfig df)
-
+resolvePackageDb _  (PackageDb name) = return $ Just name
-lookupSym' :: Options -> Symbol -> SymMdlDb -> String
+resolvePackageDb _  UserDb           = handleIO (\_ -> return Nothing) $ do
-lookupSym' opt sym db = convert opt $ lookupSym sym db
+    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

Language/Haskell/GhcMod/Ghc.hs

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

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

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

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