From 9ac128aa6fa6e23acba47cbb84e0c5411e98f182 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 14 Oct 2014 19:52:58 +0200 Subject: [PATCH] Fix #387, Pattern match failure in GhcPkg --- Language/Haskell/GhcMod/Cradle.hs | 25 ++++++++++++++++++++++-- Language/Haskell/GhcMod/Find.hs | 12 +++++------- Language/Haskell/GhcMod/GhcPkg.hs | 13 +++++++++---- Language/Haskell/GhcMod/Monad.hs | 7 ++++++- Language/Haskell/GhcMod/Types.hs | 2 ++ ghc-mod.cabal | 2 ++ src/GHCMod.hs | 2 +- test/CradleSpec.hs | 32 ++++++++++++++----------------- 8 files changed, 62 insertions(+), 33 deletions(-) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index c956b4e..112528a 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/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] } diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index addbc36..5967128 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/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 = do - crdl <- cradle - dir <- liftIO $ getPackageCachePath crdl +dumpSymbol :: IOish m => FilePath -> GhcModT m String +dumpSymbol dir = do let cache = dir symbolCache pkgdb = dir packageCache diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index c0cb2c2..a0c9bff 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/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 - Just db <- resolvePath u - return db + let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl + mdb <- join <$> resolvePath `T.traverse` mu + 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) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 5fe33b8..4d26280 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index ba681bf..3347816 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 2d324dc..0d47da2 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index bfc0826..510a6d2 100644 --- a/src/GHCMod.hs +++ b/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 diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index dbad36d..60ae5ac 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -17,31 +17,27 @@ spec = do withDirectory_ "/" $ do curDir <- stripLastDot <$> canonicalizePath "/" res <- findCradle - res `shouldBe` Cradle { - cradleCurrentDir = curDir - , cradleRootDir = curDir - , cradleCabalFile = Nothing - , cradlePkgDbStack = [GlobalDb,UserDb] - } + cradleCurrentDir res `shouldBe` curDir + cradleRootDir res `shouldBe` curDir + cradleCabalFile res `shouldBe` Nothing + cradlePkgDbStack res `shouldBe` [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 = "test" "data" "subdir1" "subdir2" - , cradleRootDir = "test" "data" - , cradleCabalFile = Just ("test" "data" "cabalapi.cabal") - , cradlePkgDbStack = [GlobalDb, PackageDb (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")] - } + cradleCurrentDir res `shouldBe` "test" "data" "subdir1" "subdir2" + cradleRootDir res `shouldBe` "test" "data" + cradleCabalFile res `shouldBe` Just ("test" "data" "cabalapi.cabal") + cradlePkgDbStack res `shouldBe` [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 = "test" "data" "broken-sandbox" - , cradleRootDir = "test" "data" "broken-sandbox" - , cradleCabalFile = Just ("test" "data" "broken-sandbox" "dummy.cabal") - , cradlePkgDbStack = [GlobalDb, UserDb] - } + cradleCurrentDir res `shouldBe` "test" "data" "broken-sandbox" + cradleRootDir res `shouldBe` "test" "data" "broken-sandbox" + cradleCabalFile res `shouldBe` Just ("test" "data" "broken-sandbox" "dummy.cabal") + cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb] relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle dir cradle = cradle {