Fix #387, Pattern match failure in GhcPkg

Language/Haskell/GhcMod/Cradle.hs

@@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Cradle (
     findCradle
   , findCradle'
   , findCradleWithoutSandbox
+  , cleanupCradle
   ) where
 
 import Language.Haskell.GhcMod.Types
@@ -12,8 +13,10 @@ import qualified Control.Exception as E
 import Control.Exception.IOChoice ((||>))
 import Control.Monad (filterM)
 import Data.List (isSuffixOf)
-import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
+import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive)
 import System.FilePath ((</>), takeDirectory)
+import System.IO.Temp
+
 
 ----------------------------------------------------------------
 
@@ -27,13 +30,26 @@ findCradle = findCradle' =<< getCurrentDirectory
 findCradle' :: FilePath -> IO Cradle
 findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
 
+newTempDir :: FilePath -> IO FilePath
+newTempDir dir =
+    flip createTempDirectory uniqPathName =<< getTemporaryDirectory
+ where
+   uniqPathName = "ghc-mod" ++ map escapeSlash dir
+   escapeSlash '/' = '-'
+   escapeSlash c = c
+
+cleanupCradle :: Cradle -> IO ()
+cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
+
 cabalCradle :: FilePath -> IO Cradle
 cabalCradle wdir = do
     (rdir,cfile) <- cabalDir wdir
     pkgDbStack <- getPackageDbStack rdir
+    tmpDir <- newTempDir rdir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = rdir
+      , cradleTempDir    = tmpDir
       , cradleCabalFile  = Just cfile
       , cradlePkgDbStack = pkgDbStack
       }
@@ -42,17 +58,22 @@ sandboxCradle :: FilePath -> IO Cradle
 sandboxCradle wdir = do
     rdir <- getSandboxDir wdir
     pkgDbStack <- getPackageDbStack rdir
+    tmpDir <- newTempDir rdir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = rdir
+      , cradleTempDir    = tmpDir
       , cradleCabalFile  = Nothing
       , cradlePkgDbStack = pkgDbStack
       }
 
 plainCradle :: FilePath -> IO Cradle
-plainCradle wdir = return Cradle {
+plainCradle wdir = do
+    tmpDir <- newTempDir wdir
+    return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = wdir
+      , cradleTempDir    = tmpDir
       , cradleCabalFile  = Nothing
       , cradlePkgDbStack = [GlobalDb, UserDb]
       }

Language/Haskell/GhcMod/Find.hs

@@ -17,7 +17,6 @@ module Language.Haskell.GhcMod.Find
 
 import Control.Applicative ((<$>))
 import Control.Monad (when, void)
-import Control.Monad.Error.Class
 import Data.Function (on)
 import Data.List (groupBy, sort)
 import Data.Maybe (fromMaybe)
@@ -87,10 +86,11 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
 ---------------------------------------------------------------
 
 -- | Loading a file and creates 'SymbolDb'.
-loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
+loadSymbolDb :: IOish m => GhcModT m SymbolDb
 loadSymbolDb = do
     ghcMod <- liftIO ghcModExecutable
-    file <- chop <$> readProcess' ghcMod ["dumpsym"]
+    tmpdir <- liftIO . getPackageCachePath =<< cradle
+    file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
     !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
     return $ SymbolDb {
         table = db
@@ -110,10 +110,8 @@ loadSymbolDb = do
 --   if the file does not exist or is invalid.
 --   The file name is printed.
 
-dumpSymbol :: IOish m => GhcModT m String
+dumpSymbol :: IOish m => FilePath -> GhcModT m String
-dumpSymbol = do
+dumpSymbol dir = do
-    crdl <- cradle
-    dir <- liftIO $ getPackageCachePath crdl
     let cache = dir </> symbolCache
         pkgdb = dir </> packageCache
 

Language/Haskell/GhcMod/GhcPkg.hs

@@ -16,16 +16,19 @@ module Language.Haskell.GhcMod.GhcPkg (
 import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
+import Control.Monad
 import qualified Control.Exception as E
 import Data.Char (isSpace)
 import Data.List (isPrefixOf, intercalate)
 import Data.List.Split (splitOn)
+import Data.Maybe
 import Distribution.Package (InstalledPackageId(..))
 import Exception (handleIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
 import System.FilePath ((</>))
+import qualified Data.Traversable as T
 
 ghcVersion :: Int
 ghcVersion = read cProjectVersionInt
@@ -117,12 +120,14 @@ packageCache = "package.cache"
 packageConfDir :: String
 packageConfDir = "package.conf.d"
 
--- fixme: error handling
 getPackageCachePath :: Cradle -> IO FilePath
 getPackageCachePath crdl = do
-    let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
+    let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl
-    Just db <- resolvePath u
+    mdb <- join <$> resolvePath `T.traverse` mu
-    return db
+    let dir = case mdb of
+               Just db -> db
+               Nothing -> cradleTempDir crdl
+    return dir
 
 --- Copied from ghc module `Packages' unfortunately it's not exported :/
 resolvePath :: GhcPkgDb -> IO (Maybe FilePath)

Language/Haskell/GhcMod/Monad.hs

@@ -244,6 +244,9 @@ newGhcModEnv opt dir = do
         , gmCradle = c
         }
 
+cleanupGhcModEnv :: GhcModEnv -> IO ()
+cleanupGhcModEnv env = cleanupCradle $ gmCradle env
+
 -- | Run a @GhcModT m@ computation.
 runGhcModT :: IOish m
            => Options
@@ -251,11 +254,13 @@ runGhcModT :: IOish m
            -> m (Either GhcModError a, GhcModLog)
 runGhcModT opt action = do
     env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
-    first (fst <$>) <$> (runGhcModT' env defaultState $ do
+    r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
         dflags <- getSessionDynFlags
         defaultCleanupHandler dflags $ do
             initializeFlagsWithCradle opt (gmCradle env)
             action)
+    liftBase $ cleanupGhcModEnv env
+    return r
 
 -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
 -- computation. Note that if the computation that returned @result@ modified the

Language/Haskell/GhcMod/Types.hs

@@ -65,6 +65,8 @@ data Cradle = Cradle {
     cradleCurrentDir :: FilePath
   -- | The project root directory.
   , cradleRootDir    :: FilePath
+  -- | Per-Project temporary directory
+  , cradleTempDir    :: FilePath
   -- | The file name of the found cabal file.
   , cradleCabalFile  :: Maybe FilePath
   -- | Package database stack

ghc-mod.cabal

@@ -109,6 +109,7 @@ Library
                       , pretty
                       , process
                       , syb
+                      , temporary
                       , time
                       , transformers
                       , transformers-base
@@ -212,6 +213,7 @@ Test-Suite spec
                       , pretty
                       , process
                       , syb
+                      , temporary
                       , time
                       , transformers
                       , transformers-base

src/GHCMod.hs

@@ -409,9 +409,9 @@ flagsCmd      = withParseCmd [] $ \[] -> flags
 debugInfoCmd  = withParseCmd [] $ \[] -> debugInfo
 rootInfoCmd   = withParseCmd [] $ \[] -> rootInfo
 -- internal
-dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol
 bootCmd       = withParseCmd [] $ \[] -> boot
 
+dumpSymbolCmd     = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir
 findSymbolCmd     = withParseCmd [] $ \[sym]  -> findSymbol sym
 pkgDocCmd         = withParseCmd [] $ \[mdl]  -> pkgDoc mdl
 lintCmd           = withParseCmd s  $ \[file] -> lint file

test/CradleSpec.hs

@@ -17,31 +17,27 @@ spec = do
             withDirectory_ "/" $ do
                 curDir <- stripLastDot <$> canonicalizePath "/"
                 res <- findCradle
-                res `shouldBe` Cradle {
+                cradleCurrentDir res `shouldBe` curDir
-                    cradleCurrentDir = curDir
+                cradleRootDir    res `shouldBe` curDir
-                  , cradleRootDir    = curDir
+                cradleCabalFile  res `shouldBe` Nothing
-                  , cradleCabalFile  = Nothing
+                cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
-                  , cradlePkgDbStack = [GlobalDb,UserDb]
+
-                  }
         it "finds a cabal file and a sandbox" $ do
             cwd <- getCurrentDirectory
             withDirectory "test/data/subdir1/subdir2" $ \dir -> do
                 res <- relativeCradle dir <$> findCradle
-                res `shouldBe` Cradle {
+                cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
-                    cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
+                cradleRootDir    res `shouldBe` "test" </> "data"
-                  , cradleRootDir    = "test" </> "data"
+                cradleCabalFile  res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
-                  , cradleCabalFile  = Just ("test" </> "data" </> "cabalapi.cabal")
+                cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
-                  , cradlePkgDbStack = [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
+
-                  }
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
                 res <- relativeCradle dir <$> findCradle
-                res `shouldBe` Cradle {
+                cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
-                    cradleCurrentDir = "test" </> "data" </> "broken-sandbox"
+                cradleRootDir    res `shouldBe` "test" </> "data" </> "broken-sandbox"
-                  , cradleRootDir    = "test" </> "data" </> "broken-sandbox"
+                cradleCabalFile  res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
-                  , cradleCabalFile  = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
+                cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
-                  , cradlePkgDbStack = [GlobalDb, UserDb]
-                  }
 
 relativeCradle :: FilePath -> Cradle -> Cradle
 relativeCradle dir cradle = cradle {