hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix #387, Pattern match failure in GhcPkg

Browse Source
This commit is contained in:
Daniel Gröber 2014-10-14 19:52:58 +02:00
parent dbe66cbaa3
commit 9ac128aa6f
8 changed files with 62 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
Language/Haskell/GhcMod/Cradle.hs
View File

@ -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]
}

12
Language/Haskell/GhcMod/Find.hs
View File

@ -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

13
Language/Haskell/GhcMod/GhcPkg.hs
View File

@ -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)

7
Language/Haskell/GhcMod/Monad.hs
View File

@ -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

2
Language/Haskell/GhcMod/Types.hs
View File

@ -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

2
ghc-mod.cabal
View File

@ -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

2
src/GHCMod.hs
View File

@ -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

32
test/CradleSpec.hs
View File

@ -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 {