Clean up Find.hs a bit

Language/Haskell/GhcMod/Find.hs

@@ -18,13 +18,14 @@ import Config (cProjectVersion,cTargetPlatformString)
 import Control.Applicative ((<$>))
 import Control.Exception (handle, SomeException(..))
 import Control.Monad (when, void)
+import Control.Monad.Error.Class
 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 (ghandle, handleIO)
+import Exception (handleIO)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
@@ -53,7 +54,7 @@ import qualified Data.Map as M
 -- | Type of function and operation names.
 type Symbol = String
 -- | Database from 'Symbol' to \['ModuleString'\].
-newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
+newtype SymbolDb = SymbolDb (Map Symbol [ModuleString]) deriving (Show)
 
 ----------------------------------------------------------------
 
@@ -117,47 +118,46 @@ readSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
 ----------------------------------------------------------------
 -- used 'ghc-mod dumpsym'
 
-getPath :: IOish m => GhcModT m (Maybe String)
+getSymbolCachePath :: IOish m => GhcModT m FilePath
-getPath = do
+getSymbolCachePath = do
-    df <- G.getSessionDynFlags
+    u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle
-    stack <- cradlePkgDbStack . gmCradle <$> ask
+    Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags
-    case filter (GlobalDb /=) stack of
+    return db
-        []  -> return Nothing
+  `catchError` const (fail "Couldn't find non-global package database for symbol cache")
-        u:_ -> liftIO $ resolvePackageDb df u
 
 -- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
 --   if the file does not exist or is invalid.
 --   The file name is printed.
 dumpSymbol :: IOish m => GhcModT m String
 dumpSymbol = do
-    mdir <- getPath
+    dir <- getSymbolCachePath
-    ret <- case mdir of
+    let cache = dir </> symbolCache
-        Nothing  -> return ""
+        pkgdb = dir </> packageCache
-        Just dir -> do
-            let cache = dir </> symbolCache
-                pkgdb = dir </> packageCache
-            ghandle (\(SomeException _) -> return "") $ do
-                create <- liftIO $ needToCreate cache pkgdb
-                when create $ do
-                    sm <- getSymbol
-                    void . liftIO $ withFile cache WriteMode $ \hdl ->
-                        mapM (hPrint hdl) sm
-                return cache
-    return $ ret ++ "\n"
 
-needToCreate :: FilePath -> FilePath -> IO Bool
+    create <- liftIO $ cache `isNewerThan` pkgdb
-needToCreate file1 file2 = do
+    when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
-    exist <- doesFileExist file1
+    return $ unlines [cache]
+
+writeSymbolCache :: FilePath
+                 -> [(Symbol,[ModuleString])]
+                 -> IO ()
+writeSymbolCache cache sm = do
+  void . withFile cache WriteMode $ \hdl ->
+      mapM (hPrint hdl) sm
+
+isNewerThan :: FilePath -> FilePath -> IO Bool
+isNewerThan ref file = do
+    exist <- doesFileExist ref
     if not exist then
         return True
       else do
-        m1 <- getModificationTime file1
+        tRef <- getModificationTime ref
-        m2 <- getModificationTime file2
+        tFile <- getModificationTime file
-        return $ m1 <= m2 -- including equal just in case
+        return $ tRef <= tFile -- including equal just in case
 
 -- | Browsing all functions in all system/user modules.
-getSymbol :: IOish m => GhcModT m [(Symbol,[ModuleString])]
+getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
-getSymbol = do
+getSymbolTable = do
     ms <- G.packageDbModules True
     let ns = map (G.moduleNameString . G.moduleName) ms
     is <- mapM G.getModuleInfo ms
@@ -166,7 +166,8 @@ getSymbol = do
 
 toNameModule :: (Maybe G.ModuleInfo,ModuleString) -> [(Symbol,ModuleString)]
 toNameModule (Nothing,_)  = []
-toNameModule (Just inf,mdlname) = map (\name -> (getOccString name, mdlname)) names
+toNameModule (Just inf,mdlname) =
+    map (\name -> (getOccString name, mdlname)) names
   where
     names = G.modInfoExports inf